Filter to determain cells to be copied, now copies the last found criteria

Question

I'm having troubles with the output of my code. Im using a macro to search for some criteria which are labeled:

Collection = Trim(Range("lblImportCollection").Value)
        System = Trim(Range("lblImportSystem").Value)
        Tag = Trim(Range("lblImportTag").Value)

My filter does search the right cell values where the input values are found, but I want to copy the matched values to a new sheet. Now it just copies the last correct value that is found. Can someone help me with it? What I want:

• If all three criteria match( I want to copy the 3 criteria in a row on the new worksheet)
• If two criteria match( I want to copy the 2 criteria in a row(and not the third one)
• If one criteria match( I want to copy the 1 criteria in a row(so not the second and the third)
• Also: All resulting matches must fill a new row. I hope I gave enough information, it's a bit hard to explain. If you have questions, let me know :)

---

Sub FilterButton()
    Dim XUsedRange As Range
    Dim SourceRange As Range, DestRange As Range
    Dim SrcSheet As Worksheet
    Dim DestSheet As Worksheet, Lr As Long
    Dim firstAddress As String
    Dim c As Range
    Dim iLastRow As Integer
    Dim zLastRow As Integer
    Dim test As String
    Dim TempRange As Range

    Dim Collection As String
    Dim System As String
    Dim Tag As String

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


    Collection = Trim(Range("lblImportCollection").Value)
    System = Trim(Range("lblImportSystem").Value)
    Tag = Trim(Range("lblImportTag").Value)

    'fill in the Source Sheet and range
    Set XUsedRange = Sheets("Imported Data").UsedRange
    Set ZUsedRange = Sheets("Test").Range("A:C")

    'Fill in the destination sheet and find the last known cell
    Set DestSheet = Sheets("Test")

    Set SrcSheet = Sheets("Imported Data")

    'With the information on the new sheet


    iLastRow = XUsedRange.End(xlDown).Row
    zLastRow = ZUsedRange.End(xlUp).Row
    Set SourceRange = SrcSheet.Range("A2:A" & CStr(iLastRow))
    Set DestRange = DestSheet.Range("A2:C" & CStr(zLastRow))

    With SourceRange
        Set c = SourceRange.Find(What:=Collection, SearchOrder:=xlByColumns)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
            MsgBox ("Found " & Collection & " on address:" & c.Address)
            c.Copy
            DestRange.PasteSpecial

            If System = SrcSheet.Range("B" & CStr(c.Row) & ":B" & CStr(c.Row)) Then

            MsgBox ("The system is " & SrcSheet.Range("B" & CStr(c.Row) & ":B" & CStr(c.Row)))
            'DestSheet.Range ("B" & CStr(c.Row) & ":B" & CStr(c.Row))

            SrcSheet.Range("B" & CStr(c.Row) & ":B" & CStr(c.Row)).Copy
            DestRange.PasteSpecial

            If Tag = SrcSheet.Range("C" & CStr(c.Row) & ":C" & CStr(c.Row)) Then

            MsgBox ("The tag is" & SrcSheet.Range("C" & CStr(c.Row) & ":C" & CStr(c.Row)))
            'DestSheet.Range ("C" & CStr(c.Row) & ":C" & CStr(c.Row))

            SrcSheet.Range("C" & CStr(c.Row) & ":C" & CStr(c.Row)).Copy
            DestRange.PasteSpecial

            End If
            End If
            Set c = SourceRange.FindNext(c)
            Loop While (Not c Is Nothing) And (c.Address <> firstAddress)
        Else
            MsgBox (Collection & " is NOT Found ")

        End If
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

Answer 1

Like I mentioned there are couple of problems with the code

1. Please use Option Explicit. That will ensure that you define your variables
2. When you define a variable which is meant to store Excel Row number then instead of Integer, use Long
3. Avoid the use of UsedRange. Get the Actual range which has "Data". Since you are only concerned with Col A, use that to find the last row. We can always use .Offset() to check for Criteria2 and Criteria3
4. Comment your code with appropriate "comments". I had a tough time understanding it.

Is this what you are trying?

Code: (UNTESTED)

Option Explicit

Sub FilterButton()
    Dim SrcSheet As Worksheet, DestSheet As Worksheet
    Dim SourceRange As Range
    Dim aCell As Range, bCell As Range
    Dim iLastRow As Long, zLastRow As Long
    Dim Collection As String, System As String, Tag As String

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

    '~~> Set your sheet
    Set DestSheet = Sheets("Test")
    Set SrcSheet = Sheets("Imported Data")

    '~~> Find Last Row in Col A in the source sheet
    With SrcSheet
        iLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
    End With

    '~~> Find Last "Available Row for Output" in Col A in the destination sheet
    With DestSheet
        zLastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
    End With

    '~~> Set your ranges
    Set SourceRange = SrcSheet.Range("A2:A" & iLastRow)

    '~~> Search values
    Collection = Trim(Range("lblImportCollection").Value)
    System = Trim(Range("lblImportSystem").Value)
    Tag = Trim(Range("lblImportTag").Value)

    With SourceRange
        '~~> Match 1st Criteria
        Set aCell = .Find(What:=Collection, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)

        '~~> If found
        If Not aCell Is Nothing Then
            Set bCell = aCell

            '~~> Copy A:C. Then match for Crit B and Crit C and remove what is not required
            DestSheet.Range("A" & zLastRow & ":" & "C" & zLastRow).Value = _
            SrcSheet.Range("A" & aCell.Row & ":" & "C" & aCell.Row).Value

            '~~> Match 2nd Criteria
            If aCell.Offset(, 1).Value = System Then
                '~~> Match 3rd Criteria
                If aCell.Offset(, 2).Value <> Tag Then _
                DestSheet.Range("C" & zLastRow).ClearContents
            Else
                DestSheet.Range("B" & zLastRow).ClearContents
            End If

            '~~> Increase last row by 1 for output
            zLastRow = zLastRow + 1

            Do
                Set aCell = .FindNext(After:=aCell)

                If Not aCell Is Nothing Then
                    If aCell.Address = bCell.Address Then Exit Do

                    '~~> Copy A:C. Then match for Crit B and Crit C
                    DestSheet.Range("A" & zLastRow & ":" & "C" & zLastRow).Value = _
                    SrcSheet.Range("A" & aCell.Row & ":" & "C" & aCell.Row).Value

                    '~~> Match 2nd Criteria
                    If aCell.Offset(, 1).Value = System Then
                        '~~> Match 3rd Criteria
                        If aCell.Offset(, 2).Value <> Tag Then _
                        DestSheet.Range("C" & zLastRow).ClearContents
                    Else
                        DestSheet.Range("B" & zLastRow).ClearContents
                    End If

                    '~~> Increase last row by 1 for output
                    zLastRow = zLastRow + 1
                Else
                    Exit Do
                End If
            Loop
        Else
            MsgBox Collection & " not Found"
        End If
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

FOLLOWUP (From Comments)

Option Explicit

Sub FilterButton()
    Dim SrcSheet As Worksheet, DestSheet As Worksheet
    Dim SourceRange As Range
    Dim aCell As Range, bCell As Range
    Dim iLastRow As Long, zLastRow As Long
    Dim Collection As String, System As String, Tag As String

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

    '~~> Set your sheet
    Set DestSheet = Sheets("Test")
    Set SrcSheet = Sheets("Imported Data")

    '~~> Find Last Row in Col A in the source sheet
    With SrcSheet
        iLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
    End With

    '~~> Find Last "Available Row for Output" in Col A in the destination sheet
    With DestSheet
        zLastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
    End With

    '~~> Set your ranges
    Set SourceRange = SrcSheet.Range("A2:A" & iLastRow)

    '~~> Search values
    Collection = Trim(Range("lblImportCollection").Value)
    System = Trim(Range("lblImportSystem").Value)
    Tag = Trim(Range("lblImportTag").Value)

    With SourceRange
        '~~> Match 1st Criteria
        Set aCell = .Find(What:=Collection, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)

        '~~> If found
        If Not aCell Is Nothing Then
            Set bCell = aCell

            '~~> Copy A:C. Then match for Crit B and Crit C and remove what is not required
            DestSheet.Range("A" & zLastRow & ":" & "C" & zLastRow).Value = _
            SrcSheet.Range("A" & aCell.Row & ":" & "C" & aCell.Row).Value

            '~~> Match 2nd Criteria
            If Len(Trim(System)) = 0 Or _
            aCell.Offset(, 1).Value <> System Then _
            DestSheet.Range("B" & zLastRow).ClearContents

            '~~> Match 3rd Criteria
            If Len(Trim(Tag)) = 0 Or _
            aCell.Offset(, 2).Value <> Tag Then _
            DestSheet.Range("C" & zLastRow).ClearContents

            '~~> Increase last row by 1 for output
            zLastRow = zLastRow + 1

            Do
                Set aCell = .FindNext(After:=aCell)

                If Not aCell Is Nothing Then
                    If aCell.Address = bCell.Address Then Exit Do

                    '~~> Match 2nd Criteria
                    If Len(Trim(System)) = 0 Or _
                    aCell.Offset(, 1).Value <> System Then _
                    DestSheet.Range("B" & zLastRow).ClearContents

                    '~~> Match 3rd Criteria
                    If Len(Trim(Tag)) = 0 Or _
                    aCell.Offset(, 2).Value <> Tag Then _
                    DestSheet.Range("C" & zLastRow).ClearContents

                    '~~> Increase last row by 1 for output
                    zLastRow = zLastRow + 1
                Else
                    Exit Do
                End If
            Loop
        Else
            MsgBox Collection & " not Found"
        End If
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub