Question

我试图过滤一些数据（sheet = "Imported Data"）并粘贴匹配到工作表（"Test"）的数据。但不知何故，它并没有完全奏效。我之前曾问过这个问题，但我现在已经尝试了3个小时，但我无法完成它！

我想要的： - 用户可以填写3个单元格，这些是标准（集合，系统和标签） - Collection为用户填写MUST，如果用户需要，其他可以留空。结果必须是整行（Column A,B and C） - 如果在所选标准中填写了一个，两个或三个标准，则必须全部匹配以复制到新表格（因此，如果一个标准留空，则结果应该是所有三个标准。但未填写的标准可以是任何标准值）。 - 如果所有条件都匹配，则从sheet="Imported Data"开始，E列的值也必须复制到工作表（"Test"），列E的此值必须是与匹配值在同一行中的单元格。如果您有任何疑问，请随意提问......这有点难以解释。我在这里先向您的帮助表示感谢！这就是我现在所拥有的：

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(xlDown).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
            MsgBox System & " Not Found"


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

            If Not DestSheet.Range("B" & zLastRow).ClearContents Or _
            DestSheet.Range("C" & zLastRow).ClearContents Then
            '~~> Copy E:E. Then match for Crit B and Crit C and remove what is not required
             DestSheet.Range("D" & zLastRow & ":" & "D" & zLastRow).Value = _
             SrcSheet.Range("E" & aCell.Row & ":" & "E" & aCell.Row).Value
             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

                    '~~> 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

Answer 1

我认为使用AdvancedFilter方法会更简单，但您的数据设置很重要。

我假设你的原始数据有五列（A：E），标题在第1行我进一步假设A：C列中的标题是“Collection”，“System”和“Tag” 我还假设“测试”没有任何重要性（如果有，而不是“清除”整个工作表，你可以改变代码只清除相关部分，也许是前四列。

在“导入的数据”表上设置条件范围（三列，两行），在第1行中的标题与数据源的A：C列中的标题相同。您可以使用数据验证来强制输入;或者你可以在宏本身内编码。或者你可以开发一个UserForm来填充这些单元格

用户填写条件后，宏应复制相关数据。如果填充了所有三个项目，它将删除列D，否则将删除列D：E。

如果我对您的数据设置方式做了一些错误的假设，您可能需要在执行过滤后删除更多列。

Option Explicit
Sub FilterButton()
    Dim SrcSheet As Worksheet, DestSheet As Worksheet
    Dim SourceRange As Range
    Dim CriteriaRange As Range
    Dim DestRange As Range

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

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

    '~~> Set your ranges
    Set SourceRange = SrcSheet.Range("a1").CurrentRegion
    Set CriteriaRange = SrcSheet.Range("H1:J2")  'or wherever
    Set DestRange = DestSheet.Range("A1")

'Activate Destination Sheet, Clear it, and run the filter
DestSheet.Activate 'Can only copy filtered data to active sheet
DestSheet.Cells.Clear
SourceRange.AdvancedFilter xlFilterCopy, CriteriaRange, DestRange

'Delete column D always, delete Column E if not three criteria
With DestRange.CurrentRegion
If WorksheetFunction.CountA(CriteriaRange.Rows(2)) <> 3 Then
    Range(.Columns(4), .Columns(5)).Delete
Else
    .Columns(4).Delete (xlToLeft)
End If
End With

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

尝试过滤数据并将其显示在另一张纸上，但数据未完全复制

1 个答案: