Search for multiple phrase; copy to single sheet across multiple sheets

Question

I am using Microsoft Excel to keep track of tasks. I use a different "sheet" for each job. The structure is with regards to columns and data. I have been trying to create a VBA script that would accomplish the following:

1. Search sheets 1 - X for a value of "Open" or "Past Due" in a row
2. Copy all rows with those values into a single sheet (such as a ledger) starting at row 3 (so I can add the headers of the template)
3. Add a column A with the sheet name so that I know what job it came from.
4. Run this to my hearts obsessive compulsive behavior pleasure to update with new items

I have been using the following posts to help guide me:

• Search a specific word and copy line to another Sheet <- which was helpful but not quite right...

• Copying rows to another worksheet based on a search on a grid of tags <-- also helpful, but limited to the activesheet and not looping correctly with my modifications...

The last two evenings have been fun, but I feel like I may be making this harder than necessary.

I was able to create a VBA script (edited from another post here) to sweep through all the worksheets, but it was designed to copy all data in a set of columns. I tested that and it worked. I then merged the code base I was using to identify "Open" or "Past Due" in column C (that worked for only the activesheet) into the code. I marked up my edits to share here. At this point it is not functioning, and I have walked myself dizzy. Any tips on where I fubar-ed the code would be appreciated. My code base I working from is:

Sub SweepSheetsCopyAll()

    Application.ScreenUpdating = False
   'following variables for worksheet loop
    Dim W As Worksheet, r As Single, i As Single
   'added code below for finding the fixed values on the sheet
    Dim lastLine As Long
    Dim findWhat As String
    Dim findWhat1 As String
    Dim findWhat2 As String
    Dim toCopy As Boolean
    Dim cell As Range
    Dim h As Long 'h replaced i variable from other code
    Dim j As Long

    'replace original findWhat value with new fixed value

    findWhat = "Open"
    'findWhat2 = "Past Due"


    i = 4
    For Each W In ThisWorkbook.Worksheets
        If W.Name <> "Summary" Then
           lastLine = ActiveSheet.UsedRange.Rows.Count 'Need to figure out way to loop all rows in a sheet to find last line
            For r = 4 To lastLine 'formerly was "To W.Cells(Rows.Count, 1).End(xlUp).Row"
                'insert below row match search copy function
                For Each cell In Range("B1:L1").Offset(r - 1, 0)
                   If InStr(cell.Text, findWhat) <> 0 Then
                      toCopy = True
                   End If
               Next
            If toCopy = True Then
    ' original code               Rows(r).Copy Destination:=Sheets(2).Rows(j)
     Range(W.Cells(r, 1), W.Cells(r, 12)).Copy _
                        ThisWorkbook.Worksheets("Summary").Cells(i, 1)
                j = j + 1
            End If
            toCopy = False
        'Next

                'end above row match search function
                'below original code that copied everything from whole worksheet
         '       If W.Cells(r, 1) > 0 Then
   '                 Range(W.Cells(r, 1), W.Cells(r, 12)).Copy _
    '                    ThisWorkbook.Worksheets("Summary").Cells(i, 1)
          '          i = i + 1
           '     End If
            Next r
        End If
    Next W
End Sub

The working code base to sweep through all the sheets was:

Sub GetParts()
    Application.ScreenUpdating = False
    Dim W As Worksheet, r As Single, i As Single
    i = 4
    For Each W In ThisWorkbook.Worksheets
        If W.Name <> "Summary" Then
            For r = 4 To W.Cells(Rows.Count, 1).End(xlUp).Row
                If W.Cells(r, 1) > 0 Then
                    Range(W.Cells(r, 1), W.Cells(r, 3)).Copy _
                        ThisWorkbook.Worksheets("Summary").Cells(i, 1)
                    i = i + 1
                End If
            Next r
        End If
    Next W
End Sub

And the copy the matched data from the Activesheet is as follows:

Sub customcopy()

Application.ScreenUpdating = False
Dim lastLine As Long
Dim findWhat As String
Dim findWhat1 As String
Dim findWhat2 As String
Dim toCopy As Boolean
Dim cell As Range
Dim i As Long
Dim j As Long

'replace original findWhat value with new fixed value

findWhat = "Open"
'findWhat2 = "Past Due"

lastLine = ActiveSheet.UsedRange.Rows.Count 'Need to figure out way to loop through all sheets here

'below code does nice job finding all findWhat and copying over to spreadsheet2
j = 1
For i = 1 To lastLine
    For Each cell In Range("B1:L1").Offset(i - 1, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
            toCopy = True
        End If
    Next
    If toCopy = True Then
        Rows(i).Copy Destination:=Sheets(2).Rows(j)
        j = j + 1
    End If
    toCopy = False
Next

i = MsgBox(((j - 1) & " row(s) were copied!"), vbOKOnly, "Result")

Application.ScreenUpdating = True
End Sub

Answer 1

You should look into this Vba macro to copy row from table if value in table meets condition

In your case, you would need to create a loop, using this advanced filter to copy the data to your target range or array.

If you need further advice, please post your code, and where you are stuck with it.