VBA code to filter values ending with certain values and then copy the date to another workbook in the same folder

[Balajibenz]

Hello there,

Can someone help me with VBA code to filter all the values in column B ending with 21 or 22 or 46 in the active workbook and then copy paste data in to the worksheet named "Data" in the workbook named output which is placed in the same folder as the active workbook.

 

[ranman256]

paste code into a module, then prep workbook for this code,
sheet FIND , has 3 rows of values to find:
21
22
46

sheet:DATA
has your data rows with col B to be searched for values on sheet FIND.
then run: FindMyData()

it will save results in : c:\temp\found data.xlsx
(alter to your result name)

Option Explicit
'---------------------
Sub FindMyData()
'---------------------
Dim iRows As Long, iFldNum As Long, iResultOFF As Long
Dim vTxt
Dim sResultCol As String
Const kResultHdr = "Results"
Const kFOUND = "found"
Dim colVals As New Collection
Dim i As Integer
  'load the legal search values
Sheets("find").Activate
Range("A1").Select
While ActiveCell.Value <> ""
   colVals.Add ActiveCell.Value
   ActiveCell.Offset(1, 0).Select 'next row
Wend
  'add a result column
Sheets("data").Activate
Range("A1").Select
Selection.End(xlToRight).Select
If InStr(ActiveCell.Value, kResultHdr) = 0 Then
   ActiveCell.Offset(0, 1).Select
   ActiveCell.Value = kResultHdr
End If
iFldNum = ActiveCell.Column
iResultOFF = iFldNum - Range("A1").Column
sResultCol = iFldNum & ":" & iFldNum
sResultCol = getMyColLtr()
  'clear results col.
Columns(iFldNum).ClearContents
Range(sResultCol & "1").Value = kResultHdr
  'get #rows
Range("A1").Select
iRows = ActiveSheet.UsedRange.Rows.Count
'MsgBox iRows
Range("A2").Select
While ActiveCell.Row <= iRows
   vTxt = ActiveCell.Offset(0, 1).Value
   For i = 1 To colVals.Count
      If Val(Right(vTxt, 2)) = Val(colVals(i)) Then
        ActiveCell.Offset(0, iResultOFF).Value = kFOUND
        Exit For
      End If
   Next
   
   ActiveCell.Offset(1, 0).Select 'next row
Wend
 'filter results
ActiveSheet.Range("A1").AutoFilter Field:=iFldNum, Criteria1:=kFOUND
Set colVals = Nothing
'copy the results
SaveFoundData
End Sub

'---------------------
Public Function getMyColLtr()
'---------------------
Dim vRet
Dim i As Integer
vRet = Mid(ActiveCell.Address, 2)
i = InStr(vRet, "$")
If i > 0 Then vRet = Left(vRet, i - 1)
getMyColLtr = vRet
End Function


'---------------------
Sub SaveFoundData()
'---------------------
Range("A1").Select
ActiveSheet.UsedRange.Select
     'Range("A1:G27").Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
   
    ActiveWorkbook.SaveAs Filename:="C:\TEMP\found data.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub

 

[kevin9999]

Another option?
Assumes your source data is on a sheet named "Sheet1", and that you want the filtered data copied to cell A1 in the sheet "Data" in a workbook called "output.xlsx". These variables can be tweaked as required.

Option Explicit
Sub balajibenz()
    Dim arrIn, arrOut, lr As Long, i As Long, c As Range, arr() As Variant
    Dim wb1 As Workbook
    Dim ws1 As Worksheet
    Set wb1 = ThisWorkbook
    Set ws1 = wb1.Sheets("Sheet1")
    
    Dim wb2 As Workbook, FileName As String, temp As String
    FileName = ThisWorkbook.Path & "\output.xlsx"
    Set wb2 = Workbooks.Open(FileName)
    
    Dim ws2 As Worksheet
    Set ws2 = wb2.Sheets("Data")
    
    lr = ws1.Cells(Rows.Count, 2).End(xlUp).Row
    For Each c In ws1.Range("B2:B" & lr)
        temp = Right(c, 2)
        If temp = "21" Or _
        temp = "22" Or _
        temp = "46" Then
        ReDim Preserve arr(i)
            arr(i) = CStr(c)
            i = i + 1
        End If
    Next c
    
    With ws1.Range("A1").CurrentRegion
        .AutoFilter 2, Array(arr), 7
        .Offset(1).Copy ws2.Cells(1)
        .AutoFilter
    End With
End Sub

 

[Balajibenz]

.AutoFilter 2, Array(arr), 7

Getting an error

Another option?
Assumes your source data is on a sheet named "Sheet1", and that you want the filtered data copied to cell A1 in the sheet "Data" in a workbook called "output.xlsx". These variables can be tweaked as required.

Option Explicit
Sub balajibenz()
    Dim arrIn, arrOut, lr As Long, i As Long, c As Range, arr() As Variant
    Dim wb1 As Workbook
    Dim ws1 As Worksheet
    Set wb1 = ThisWorkbook
    Set ws1 = wb1.Sheets("Sheet1")
   
    Dim wb2 As Workbook, FileName As String, temp As String
    FileName = ThisWorkbook.Path & "\output.xlsx"
    Set wb2 = Workbooks.Open(FileName)
   
    Dim ws2 As Worksheet
    Set ws2 = wb2.Sheets("Data")
   
    lr = ws1.Cells(Rows.Count, 2).End(xlUp).Row
    For Each c In ws1.Range("B2:B" & lr)
        temp = Right(c, 2)
        If temp = "21" Or _
        temp = "22" Or _
        temp = "46" Then
        ReDim Preserve arr(i)
            arr(i) = CStr(c)
            i = i + 1
        End If
    Next c
   
    With ws1.Range("A1").CurrentRegion
        .AutoFilter 2, Array(arr), 7
        .Offset(1).Copy ws2.Cells(1)
        .AutoFilter
    End With
End Sub

That works like a gem, Thanks mate

 

[kevin9999]

Getting an error

That works like a gem, Thanks mate

Just to clarify, did the code suggested work as it was, or did you change the line you say you were getting an error on? If you did change it, what did you change it to? Cheers ?

 

[Balajibenz]

Just to clarify, did the code suggested work as it was, or did you change the line you say you were getting an error on? If you did change it, what did you change it to? Cheers ?

Error was my mistake mate and the code does exactly what Expected. Can ypu help me with an addition this where the filtered values must strictly begin with 180, I have created a temp2 = left (c, 3) and then included it in the code with and condition but still values not starting with "180" are getting filtered.

 

[kevin9999]

Error was my mistake mate and the code does exactly what Expected. Can ypu help me with an addition this where the filtered values must strictly begin with 180, I have created a temp2 = left (c, 3) and then included it in the code with and condition but still values not starting with "180" are getting filtered.

That's odd, it does actually work - I just tested it. Could you post the full code you are using now including the additional 180 requirement?

 

[Balajibenz]

Thanks @kevin9999 , It worked perfectly once i put a all the OR conditions in the braces.

That's odd, it does actually work - I just tested it. Could you post the full code you are using now including the additional 180 requirement?

 

[kevin9999]

Thanks @kevin9999 , It worked perfectly once i put a all the OR conditions in the braces.

Good to hear you worked it out and thanks for the feedback ?

 

[Balajibenz]

Hi @kevin9999 , can you please help me with an additional requirement for the above thread.

I have raised new thread in the below link.

VBA code to adding additional filter with array

I have below code which i use for copying the filtered data to another sheet(ws2). Sub VBA() ws1.Activate lr = ws1.Cells(Rows.Count, 16).End(xlUp).Row For Each c In ws1.Range("P2:P" & lr) temp2 = Left(c, 3) temp = Right(c, 3) temp3 = c.Offset(0, -5)...

www.mrexcel.com