1

I would like to have a macro which copies all data from several tabs, which are in line with filter line defined in "Summary (Filtered)" tab. Here are the details:

  1. All tabs have the same headers.
  2. The filter line is row 7 in tab "Summary (Filtered)".
  3. I want to loop through every tab except for those listed below, check every row and copy it to Summary tab if it satisfies the filter (if given cell in filter line is empty, all values are permitted, otherwise it must match).
  4. I would like the copying to start in line 9 of Summary tab.

I have tried to solve it by the loop functions, but I get application or object defined error. Also, I imagine that the effectiveness of double loops is very poor.

Sub CopyDataFiltered()
    Dim sh          As Worksheet
    Dim SourceSh    As Worksheet
    Dim Last        As Long
    Dim shLast      As Long
    Dim CopyRng     As Range
    Dim StartRow    As Long
    Dim lrow        As Long
    Dim r           As Long
    Dim col         As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set SourceSh = ActiveWorkbook.Worksheets("Summary (Filtered)")
    Application.DisplayAlerts = False
    On Error Resume Next
    On Error GoTo 0

    For Each sh In ActiveWorkbook.Worksheets
        If IsError(Application.Match(sh.Name, Array(SourceSh.Name, "List Data", "Summary (All)", "Lists"), 0)) Then

            lrow = LastRow(sh)

            If lrow < 7 Then
                'MsgBox ("Nothing to move")
                GoTo NextTab
            End If

            For r = LastRow(sh) To 7 Step -1
                For col = 1 To 16

                    If SourceSh.Range(7, col).Value <> "" And SourceSh.Range(7, col).Value <> sh.Range(r, col).Value Then
                        GoTo End1
                    End If

                Next col
                sh.Rows(r).Copy Destination:=SourceSh.Range("A" & LastRow(SourceSh) + 1)

End1:
            Next r
        End If
NextTab:
    Next

ExitTheSub:
    Application.Goto SourceSh.Cells(1)
    Application.DisplayAlerts = True
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Could you please take a look and let me know what you think would be the best?

Pᴇʜ
  • 56,719
  • 10
  • 49
  • 73
John
  • 43
  • 7

1 Answers1

2

So here is almost your same approach, just reworked into a form that isolates each step of your process clarify what you want to accomplish. Having a nested loop is not a problem, as long as you keep track of what you're trying to do. What I do want to steer you away from is using GoTo statements. They are almost never necessary.

So first things first...

Always use Option Explicit and declare your variables as close as possible to where you want to use them. This habit makes it easier to understand what each variable is and what it's used for. If you declare them all at the top, you'll always be popping back and forth to find them.

Option Explicit

Sub CopyFilteredData()
    Dim srcWB As Workbook
    Dim srcWS As Worksheet
    Set srcWB = ActiveWorkbook
    Set srcWS = srcWB.Sheets("Summary (Filtered)")

Since you will always be referring to your filter in the same location, just define a variable that specifically matches your filter. The bonus here is if your filter changes from row 7 to row 8 (for example), you only have to change it in one spot.

    Dim srcFilter As Range
    Set srcFilter = srcWS.Range("A7").Resize(1, 16)

Using the same idea, set up a variable that clearly defines the worksheets to skip:

    Dim skipTheseSheets As Variant
    skipTheseSheets = Array(srcWS.Name, "List Data", "Summary (All)", "Lists")
    Dim sh As Worksheet
    For Each sh In srcWB.Sheets
        If Not IsInArray(sh.Name, skipTheseSheets) Then

This answer gives an excellent function to check if your worksheet name exists in that array.

You didn't include your function for LastRow, so I included it in my answer. However, make a habit of naming your functions using a verb that is descriptive of what the function does. In this case FindLastRow.

In order to stop using GoTo statements, just reverse the If statement and proceed if it passes:

Dim lastRow As Long
lastRow = FindLastRow(sh)
If lastRow > 7 Then

I created a separate function that compares a given row against your filter. It uses basically your same logic, but by isolating it as a function, it makes your main logic read more simply. Also, notice that you can exit a For loop and avoid the dreaded GoTo:

Private Function RowMatchesFilter(ByRef thisRow As Range, _
                                  ByRef thisFilter As Range) As Boolean
    '--- the row matches only if the value in thisRow equals the value
    '    in the filter
    RowMatchesFilter = True
    Dim i As Long
    For i = 1 To 16
        If Not IsEmpty(thisFilter.Cells(1, i).Value) Then
            If thisRow.Cells(1, i).Value <> thisFilter.Cells(1, i).Value Then
                '--- the first cell that doesn't match invalidates the
                '    entire row
                RowMatchesFilter = False
                Exit For
            End If
        End If
    Next i
End Function

So your copy loop ends up looking like this:

Dim r As Long
For r = lastRow To 7 Step -1
    If RowMatchesFilter(sh.Rows(r), srcFilter) Then
        sh.Rows(r).Copy
        srcWS.Range("A" & FindLastRow(srcWS) + 1).PasteSpecial xlPasteAll
    End If
Next r

Here is the whole module:

Option Explicit

Sub CopyFilteredData()
    Dim srcWB As Workbook
    Dim srcWS As Worksheet
    Set srcWB = ActiveWorkbook
    Set srcWS = srcWB.Sheets("Summary (Filtered)")

    Dim srcFilter As Range
    Set srcFilter = srcWS.Range("A7").Resize(1, 16)

    Dim skipTheseSheets As Variant
    skipTheseSheets = Array(srcWS.Name, "List Data", "Summary (All)", "Lists")

    Dim sh As Worksheet
    For Each sh In srcWB.Sheets
        If Not IsInArray(sh.Name, skipTheseSheets) Then
            Dim lastRow As Long
            lastRow = FindLastRow(sh)
            If lastRow > 7 Then
                '--- now copy the data from this sheet back to the source
                '    in reverse order, using the source filter line to
                '    direct which cells to copy
                Dim r As Long
                For r = lastRow To 7 Step -1
                    If RowMatchesFilter(sh.Rows(r), srcFilter) Then
                        sh.Rows(r).Copy
                        srcWS.Range("A" & FindLastRow(srcWS) + 1).PasteSpecial xlPasteAll
                    End If
                Next r
            End If
        End If
    Next sh
End Sub

Private Function IsInArray(ByVal stringToBeFound As String, _
                           ByRef arr As Variant) As Boolean
  IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function

Private Function FindLastRow(ByRef thisWS As Worksheet) As Long
    With thisWS
        FindLastRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
    End With
End Function

Private Function RowMatchesFilter(ByRef thisRow As Range, _
                                  ByRef thisFilter As Range) As Boolean
    '--- the row matches only if the value in thisRow equals the value
    '    in the filter
    RowMatchesFilter = True
    Dim i As Long
    For i = 1 To 16
        If Not IsEmpty(thisFilter.Cells(1, i).Value) Then
            If thisRow.Cells(1, i).Value <> thisFilter.Cells(1, i).Value Then
                '--- the first cell that doesn't match invalidates the
                '    entire row
                RowMatchesFilter = False
                Exit For
            End If
        End If
    Next i
End Function
PeterT
  • 8,232
  • 1
  • 17
  • 38
  • That's brilliant, man - works like a dram, thank you! I don't have any additional questions. The only issue was with FindLastRow function but I solved it. Great work! – John Jan 02 '19 at 15:35
  • Hello, I would like to reopen the thread as there is one problem which I didn't anticipate. As of now, the macro has problem when in source tabs, the different values appear based on formula. Namely it is either "Check" or blank (""). Once in filter line there is only those with Check in source tab, the macro doesn't return correct data (also brings up blanks, but not all of them) I would really appreciate your help on that one. – John Jan 23 '19 at 13:39
  • I'm a little unclear what you're asking, and since it seems like a separate question it's best to go ahead and create a new question. You can link back to this post if you like, but still share example data and code so folks here can have the best chance to get you a quick answer. – PeterT Jan 23 '19 at 17:43
  • I've created another question with the reference to this one as the problem may be considered as different. You may find it here: https://stackoverflow.com/questions/54365213/macro-for-copying-data-based-on-a-formula-based-on-filtered-line – John Jan 25 '19 at 12:19