How to search for multiple Values within Sheets and copy them

Geodav 0
Viewed 35

Hello this code does the following: Loops through all Sheets, looks for specifc Values within the Sheets ("08" and "09"). If found then paste entire row in a new sheet. I'm struggling with adding more values to search. So not only values "08","09" should be searched but als for example "10","11" and so on. Perhaps someone can help me modify it. Thanks

Sub Filter()
Dim ws As Worksheet, i%, C As Range, D As Range, E As Range
Application.ScreenUpdating = False
Set ws = Worksheets.Add(before:=Worksheets(1))
For i = 2 To Worksheets.Count
  With Worksheets(i)
    Set C = .Columns("A").Find(What:="Day", LookAt:=xlWhole, SearchDirection:=xlNext)
    Set D = .Cells(Rows.Count, "A").End(xlUp)(1, 4)
    Set E = ws.Cells(Rows.Count, "A").End(xlUp)(2)
    E = C.Value: E(2) = "'08": E(3) = "'09"
    .Range(C, D).AdvancedFilter 2, E.Resize(3), E(4), False
    E.Resize(3 - CInt(E.Row <> 2)).EntireRow.Delete
  End With
Next
Application.ScreenUpdating = True
End Sub
vba excel
2 Answers

You can use an array for the values to be filtered, and you only need to create the criteria range once.

Try this:

Sub Filter()
    
    Const DAY_HDR As String = "Day"  'use Const for fixed values
    Dim ws As Worksheet, i%, C As Range, D As Range
    Dim arrFilt, sz As Long, rngFilt As Range, wb As Workbook
    
    arrFilt = Array("08", "09", "10", "11")      'all filter values
    sz = 1 + (UBound(arrFilt) - LBound(arrFilt)) '# of filter values
    
    Set wb = ActiveWorkbook  'or ThisWorkbook, but best to be explicit
    Set ws = wb.Worksheets.Add(Before:=Worksheets(1))
    ws.Name = "Filtered values"
    ws.Range("A2").Value = DAY_HDR 'adding the criteria range once on the new sheet...
    With ws.Range("A3").Resize(sz)
        .NumberFormat = "@"
        .Value = Application.Transpose(arrFilt)
    End With
    Set rngFilt = ws.Range("A2").Resize(sz + 1) 'set the filter range
    
    For i = 2 To wb.Worksheets.Count
      With Worksheets(i)
        Set C = .Columns("A").Find(What:=DAY_HDR, LookAt:=xlWhole, _
                                   SearchDirection:=xlNext)
        Set D = .Cells(Rows.Count, "A").End(xlUp).Offset(0, 3)
        
        .Range(C, D).AdvancedFilter 2, rngFilt, _
            ws.Cells(Rows.Count, "A").End(xlUp).Offset(2), False
      
      End With
    Next
    
    rngFilt.EntireRow.Delete 'remove the criteria range
   
End Sub
useryB020 
Sub count()
totalsheets = Worksheets.count

mykeyword = Worksheets("Mastersheet").Cells(2, 19).Value
mykeyword2 = Worksheets("Mastersheet").Cells(3, 19).Value
Dim message As String

For i = 1 To totalsheets

If Worksheets(i).Name <> "Mastersheet" Then
    lastrow = Worksheets(i).Cells(Rows.count, 1).End(xlUp).Row
    For j = 8 To lastrow
    
    If Worksheets(i).Cells(j, 1).Value = mykeyword Then
    
    Worksheets("Mastersheet").Activate
    
    lastrow = Worksheets("Mastersheet").Cells(Rows.count, 1).End(xlUp).Row
    Worksheets("Mastersheet").Cells(lastrow + 1, 1).Value = Worksheets(i).Cells(j, 1).Value

ElseIf Worksheets(i).Cells(j, 1).Value = mykeyword2 Then
    Worksheets("Mastersheet").Activate
    
    lastrow = Worksheets("Mastersheet").Cells(Rows.count, 1).End(xlUp).Row
    Worksheets("Mastersheet").Cells(lastrow + 1, 1).Value = Worksheets(i).Cells(j, 1).Value

    End If


 Next
 
 End If
 Next


End Sub
Geodav0
Related