-1

我试图过滤一些数据（工作表= "Imported Data"）并将匹配的数据粘贴到工作表（"Test"）。但是不知何故，它并不能完全起作用。我以前问过这样的问题，但我已经尝试了 3 个小时，但我无法完成！

我想要什么： - 用户可以填写 3 个单个单元格，它们是标准（集合、系统和标签） - 集合是MUST用户填写的，如果用户想要，其他可以留空。结果必须是整行（Column A,B and C） - 如果填写了一个、两个或三个条件，则所选条件必须全部匹配才能复制到新工作表（因此，如果一个条件留空，则结果应该是所有三个条件。但未填写的可以是任意值）。- 如果所有条件都匹配，则sheet="Imported Data"还必须将列 E 的值复制到 sheet( "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
4

1 回答 1

0

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

我假设您的原始数据有五列 (A:E)，标题在第 1 行我进一步假设列 A:C 中的标题是“集合”、“系统”和“标签”我还假设“测试”没有什么重要的（如果有，而不是“清除”整个工作表，您可以更改代码以仅清除相关部分，也许是前四列。

在您的导入数据表上设置一个标准范围（三列，两行），第 1 行的标题与数据源的 A:C 列中的标题相同。您可以使用数据验证来强制输入；或者您可以在宏本身中编写一些代码。或者您可以开发一个用户窗体来填充这些单元格

用户填写条件后，宏应复制相关数据。如果所有三个项目都已填充，它将删除 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
于 2013-10-13T17:47:34.933 回答