Table（ListObject）自动过滤：带通配符的多个条件

• 您只能使用2个包含通配符的条件和AutoFilter。
  快速修复

Sub MaterialWiseFix()
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    Dim tbl As ListObject: Set tbl = ws.ListObjects("Clients")
    
    Dim cCell As Range: Set cCell = ws.Range("D4")
    
    Dim cArr() As String: cArr = Split(CStr(cCell.Value), ",")
    
    With tbl
        If .ShowAutoFilter Then
            If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
        End If
        With .Range
            Select Case UBound(cArr)
            Case Is < LBound(cArr)
                MsgBox "No criteria.", vbCritical
            Case 0
                .AutoFilter 9, "*" & cArr(0) & "*"
            Case Else
                .AutoFilter 9, "*" & cArr(0) & "*", xlOr, "*" & cArr(1) & "*"
                If UBound(cArr) > 1 Then
                    MsgBox "Only filtered by the first two criteria. " _
                        & "There are more.", vbExclamation
                End If
            End Select
        End With
    End With

End Sub

解决方案

Sub MaterialWise()
    
    ' Define constants.
    Const TableName As String = "Clients"
    Const CriteriaCellAddress As String = "D4"
    Const Delimiter As String = ","
    Const CriteriaColumn As Long = 9
    
    ' 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