当条件有更多用逗号分隔的单词并且位于另一张纸中时，VBA 中的自动过滤器

Question

我不懂编码。我想为其 Criteria1 位于另一张工作表的单元格 D1 中的条件编写以下 VBA 代码。请指导我。
非常感谢您的努力。
数据表位于“Projects”表和表=“projectstbl”中，数据列=AC列，字段=29，标题=第1行，表范围=A2:AQ2100
标准位于“关键词分析”表，D1单元格

VBA代码：

Sub MaterialWise()
    
    ' Define constants.
    Const TableName As String = "projectstbl"
    Const CriteriaCellAddress As String = "D1"
    Const Delimiter As String = ", "
    Const CriteriaColumn As Long = 4
    
    ' Reference the worksheet ('ws').
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    ' Reference the table ('tbl').
    Dim tbl As ListObject: Set tbl = ws.ListObjects(TableName)
    ' Reference the Criteria cell ('cCell').
    Dim cCell As Range: Set cCell = ws.Range(CriteriaCellAddress)
    
    ' Using the Split function, write the criteria strings
    ' to the Criteria array ('cArr'), a 1D zero-based array.
    Dim cArr() As String: cArr = Split(CStr(cCell.Value), Delimiter)
    
    ' Clear table filters.
    With tbl
        If .ShowAutoFilter Then
            If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
        End If
    End With
    
    Dim FoundMore As Boolean
    
    ' Handle up to two criteria...
    
    With tbl.Range
        Select Case UBound(cArr)
        Case Is < LBound(cArr) ' blanks
            .AutoFilter CriteriaColumn, ""
        Case 0 ' 1 criterion
            .AutoFilter CriteriaColumn, "*" & cArr(0) & "*"
        Case 1 ' 2 criteria
            .AutoFilter CriteriaColumn, _
                "*" & cArr(0) & "*", xlOr, "*" & cArr(1) & "*"
        Case Else
            FoundMore = True
        End Select
    End With
    
    If Not FoundMore Then Exit Sub
    
    ' Handle more than two criteria...
    
    ' Write the values from the column to the Data array ('Data'),
    ' a 2D one-based one-column array.
    Dim Data() As Variant
    With tbl.DataBodyRange.Columns(CriteriaColumn)
        If .Rows.Count = 1 Then ' one cell
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
        Else ' multiple cells
            Data = .Value
        End If
    End With
    
    ' Create and reference a new dictionary object ('dict').
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive
    
    ' Write the Criteria array's upper limit to a variable ('cUpper')
    ' since it's going to be used in a loop.
    Dim cUpper As Long: cUpper = UBound(cArr)
    
    ' Declare additional variables.
    Dim r As Long ' Data Array Row Counter
    Dim c As Long ' Criteria Array Elements Counter
    Dim cString As String ' Current String in Data Array
    
    ' Write the unique strings in the Data array, meeting any of the criteria,
    ' to the 'keys' of the dictionary.
    For r = 1 To UBound(Data, 1)
        cString = CStr(Data(r, 1))
        For c = 0 To cUpper
            If InStr(1, cString, cArr(c), vbTextCompare) > 0 Then Exit For
        Next c
        If c <= cUpper Then dict(cString) = Empty
    Next r
    
    ' Filter the table by the 'keys' of the dictionary.
    tbl.Range.AutoFilter CriteriaColumn, dict.Keys, xlFilterValues

End Sub

Answer 1

您拥有的代码使此任务看起来很复杂，但实际上相当简单。像这样的东西应该对你有用：

Sub tgr()
    
    Dim wb As Workbook:         Set wb = ThisWorkbook
    Dim wsData As Worksheet:    Set wsData = wb.Worksheets("Projects")
    Dim wsKeys As Worksheet:    Set wsKeys = wb.Worksheets("keywords analysis")
    Dim rKeys As Range:         Set rKeys = wsKeys.Range("D1")
    
    'If no data for filter, exit sub, otherwise collect the filter keys into an array
    If Len(rKeys.Value) = 0 Then Exit Sub   'No data
    Dim aKeys As Variant:   aKeys = Split(rKeys.Value, ", ")
    
    'Unfilter the sheet if it's already filtered
    If wsData.AutoFilterMode Then wsData.AutoFilter.ShowAllData
    
    'Apply filter using the keys collected
    With wsData.ListObjects("projectstbl").Range
        '4 is the column number to filter (column D if your data starts in column A)
        .AutoFilter 4, aKeys, xlFilterValues
    End With
    
End Sub