2016 Excel VBA Loop Multiple Worksheets Based on Search Criteria and Copy

[crazzyapple]

Hello;

I have this VBA code that searches a sheet called Data, which is based on search criteria that is located in Cell P2 on Sheet VRF and copies it under P2. It works fine. However, I would like to search all sheets and copy. I found this code on the Microsoft Support webpage to loop through multiple worksheets, but I am not sure on how to combine them. If someone could help me, that would be greatly appreciated.

Sub SearchData()
Dim employeename As String
Dim finalrow As Integer
Dim i As Integer

Sheets("VRF").Range("P3:Z100").ClearContents
employeename = Sheets("VRF").Range("P2").Value
finalrow = Sheets("Data").Range("A1000").End(xlUp).Row

For i = 2 To finalrow
If Cells(i, 1) = employeename Then
Range(Cells(i, 2), Cells(i, 11)).Copy
Sheets("VRF").Range("P100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
End If
Next i

End Sub

Sub WorksheetLoop()

         Dim WS_Count As Integer
         Dim I As Integer

         ' Set WS_Count equal to the number of worksheets in the active
         ' workbook.
         WS_Count = ActiveWorkbook.Worksheets.Count

         ' Begin the loop.
         For I = 1 To WS_Count

            ' Insert your code here.
            ' The following line shows how to reference a sheet within
            ' the loop by displaying the worksheet name in a dialog box.
            MsgBox ActiveWorkbook.Worksheets(I).Name

         Next I

      End Sub

 

[Takae]

Hope this helps.

Sub SearchData()
Dim employeename As String
Dim w, VRFws As Worksheet

Set VRFws = Sheets("VRF")

With VRFws
    .Range(.Range("P3"), .Range("P3").SpecialCells(xlLastCell).Offset(1, 0)).ClearContents
    employeename = .Range("P2").value
End With

For Each w In Worksheets
    If w.Name <> "VRF" Then
        w.Range("A1").AutoFilter , field:=1, Criteria1:=employeename
        If WorksheetFunction.Subtotal(3, w.Range("A:A")) > 1 Then
            w.Range("A1").CurrentRegion.Offset(1, 0).Resize(w.Rows.Count - 1).Copy VRFws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
        w.Range("A1").AutoFilter
    End If
Next

End Sub

 

[crazzyapple]

Hi Takae

Thank you for your quick response, and for you to rewrite it – much love. Your code does run, but if I run it again, it gives an error “application-defined or object error” on line:

.Range(.Range("P3"), .Range("P3").SpecialCells(xlLastCell).Offset(1, 0)).ClearContents

 

[crazzyapple]

update: I changed this

.Range(.Range("P3"), .Range("P3").SpecialCells(xlLastCell).Offset(1, 0)).ClearContents

to this

Sheets("VRF").Range("A1:B250").ClearContents

And depending what I pick is now giving an error for w.Range("A1").CurrentRegion.Offset(1, 0).Resize(w.Rows.Count - 1).Copy VRFws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

 

[Takae]

wow, I'm sorry I made a lot of mistakes.
".Range("P3:Z100").ClearContents" I changed this line. and pasted data too.
Please try this again.

Sub SearchData()
Dim employeename As String
Dim w, VRFws As Worksheet

Set VRFws = Sheets("VRF")

With VRFws
    '.Range("A1:B250").ClearContents
    .Range("P3:Z100").ClearContents
    employeename = .Range("P2").value
End With

For Each w In Worksheets
    If w.Name <> "VRF" Then
        w.Range("A1").AutoFilter , field:=1, Criteria1:=employeename
        If WorksheetFunction.Subtotal(3, w.Range("A:A")) > 1 Then
            w.Range(w.Range("B2"), w.Cells(Rows.Count, 11).End(xlUp)).Copy VRFws.Cells(Rows.Count, 16).End(xlUp).Offset(1, 0)
        End If
        w.Range("A1").AutoFilter
    End If
Next

End Sub

 

[crazzyapple]

This is hard to explain on what is going on. Depending on what I pick from P2, it changes where and how it is displayed on VRF. P2 is a Data Validation List that is coming from Sheet4, which is hidden. I thought maybe since it is hidden, the search function would ignore it, maybe it is not. I uploaded the file to filebin, so you can see what i am talking about.Excel Book

 

[Takae]

I added a line to avoid Sheet4.

Sub SearchData()
Dim employeename As String
Dim w, VRFws As Worksheet

Set VRFws = Sheets("VRF")

With VRFws
    .Range("P3:Z100").ClearContents
    employeename = .Range("P2").Value
End With

For Each w In Worksheets
    If w.Name <> "VRF" And w.Name <> "Sheet4" Then
        w.Range("A1").AutoFilter , field:=1, Criteria1:=employeename
        If WorksheetFunction.Subtotal(3, w.Range("A:A")) > 1 Then
            w.Range(w.Range("B2"), w.Cells(Rows.Count, 11).End(xlUp)).Copy VRFws.Cells(Rows.Count, 16).End(xlUp).Offset(1, 0)
        End If
        w.Range("A1").AutoFilter
    End If
Next
End Sub

and you can use sheet module of VRFsheet. Automatically display the results whenever P2 changes.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim w, VRFws As Worksheet
    
    If Intersect(Target, Range("P2")) Is Nothing Then
        Exit Sub
    Else
        Set VRFws = Sheets("VRF")
        Application.EnableEvents = False
        VRFws.Range("P3:Z100").ClearContents
        
        For Each w In Worksheets
            If w.Name <> "VRF" And w.Name <> "Sheet4" Then
                w.Range("A1").AutoFilter , field:=1, Criteria1:=Target.Value
                If WorksheetFunction.Subtotal(3, w.Range("A:A")) > 1 Then
                    w.Range(w.Range("B2"), w.Cells(Rows.Count, 11).End(xlUp)).Copy VRFws.Cells(Rows.Count, 16).End(xlUp).Offset(1, 0)
                End If
                w.Range("A1").AutoFilter
            End If
        Next
    End If
    Application.EnableEvents = True
End Sub

 

[crazzyapple]

Thanks again. The display is off when counting/coping to P3. Hopefully this makes sense. I displayed it in a Table on how it looks on Sheet VRF.

Kim/Bob look same

P	Q
	Location

Ted

P	Q
	Location
Laptop	Main
	Location
Laptop	Main

Changed “B2” to “A2” - I change the line to this

w.Range(w.Range("A2"), w.Cells(Rows.Count, 11).End(xlUp)).Copy VRFws.Cells(Rows.Count, 16).End(xlUp).Offset(1, 0)

This is how I would like it, It starts to display by row and look at the other sheets, not sure what is causing it to be different for each selection in P2.

Ted

P	Q	R
Employee	type	location
ted	laptop	main
Employee	type	location
ted	laptop	main

Kim/bob look the same

P	Q	R
Employee	type	location
Employee	type	location

 

[Takae]

Please enter some data up to column K of the sample data before testing.

 

[crazzyapple]

Good point, thank you Takae. I changed w.Cells(Rows.Count, 11) to w.Cells(Rows.Count, 3) and everything is good. I appreciate your help and your brain.