excel - 过滤以确定要复制的单元格，现在复制最后找到的条件

Question

我的代码输出有问题。我使用宏来搜索一些标记的条件:

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

我的过滤器会搜索找到输入值的正确单元格值，但我想将匹配的值复制到新工作表中。现在它只是复制找到的最后一个正确值。有人可以帮我吗？我想要的是:

如果所有三个条件都匹配(我想在新工作表上连续复制 3 个条件)

如果两个条件匹配(我想连续复制两个条件(而不是第三个)

如果一个条件匹配(我想连续复制 1 个条件(所以不是第二个和第三个)

另外:所有结果匹配必须填充一个新行。
我希望我提供了足够的信息，这有点难以解释。如果您有任何问题，请告诉我:)

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

就像我提到的代码有几个问题

请使用Option Explicit .这将确保您定义变量

当您定义一个用于存储 Excel 行号的变量时，而不是 Integer , 使用 Long

避免使用 UsedRange .获取具有“数据”的实际范围。由于您只关心 Col A，因此使用它来查找最后一行。我们总是可以使用 .Offset()检查 Criteria2和 Criteria3

用适当的“评论”评论您的代码。我很难理解它。

这是你正在尝试的吗？

代码:(未测试)

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

跟进(来自评论)

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