使用字典的多个条件自动过滤

Question

我正在尝试使用数组过滤具有多个条件的列。
我认为可以使用 Dictionary 来完成，就像这个问题的公认答案Link.
我稍微调整了代码，但我在这一行得到了（类型不匹配错误）：

If Application.Match(filter_Criteria(i), subStrings, 0) Then

注意：如果有其他答案（不使用辅助列）非常欢迎。

Sub AutoFilter_With_Multiple_Criteria()

    Const filter_Column As Long = 2
    Const filter_Delimiter As String = " "
    
    Dim filter_Criteria() As Variant
    filter_Criteria = Array("Cathodic Protection", "C.P", "Riser")
    
    Dim ws As Worksheet:    Set ws = ActiveSheet
    
    Dim rg As Range
    Set rg = ws.UsedRange.Resize(ws.UsedRange.Rows.count - 1).Offset(1) 'the source range (UsedRange except the first Row)

    Dim rCount As Long, arr() As Variant
    rCount = rg.Rows.count - 1
    arr = rg.Columns(filter_Column).Resize(rCount).Offset(1).value      'Write the values from criteria column to an array.
        
    Dim dict As New Dictionary                                    'Write the matching strings to the keys (a 1D array) of a dictionary.
    
    Dim subStrings() As String, r As Long, i As Long, rStr As String
    
    For r = 1 To rCount                                           'Loop through the elements of the array.
        rStr = arr(r, 1)                                          'Convert the current value to a string and store it in a variable.
        If Len(rStr) > 0 Then                                     'is not blank
           subStrings = Split(rStr, filter_Delimiter)                 'Split the string into an array.
            For i = 0 To UBound(filter_Criteria)
              If Application.Match(filter_Criteria(i), subStrings, 0) Then
                If Not dict.Exists(rStr) Then
                    dict(rStr) = Empty
                End If
              End If
            Next i
        End If
    Next r
    
    If dict.count > 0 Then
        rg.AutoFilter Field:=filter_Column, Criteria1:=dict.Keys, Operator:=xlFilterValues   'use the keys of the dictionary (a 1D array) as a Criteria
    End If
    
End Sub
 

Answer 1

使用字典自动过滤

数组（吹毛求疵！？）

• 为了确保

  Array

  函数返回一个从零开始的数组，您最好使用以下 (

  VBA.

  )：

  filter_Criteria = VBA.Array("Cathodic Protection", "C.P", "Riser")
  

• 如果你不想做前面的，使用下面的（

  LBound

  （几位顶级贡献者推荐））：

  For i = LBound(filter_Criteria) To UBound(filter_Criteria)
  

• 使用

  Split

  函数时生成的数组始终是一维从零开始的字符串数组。

循环

• 循环减慢代码。只要“可能”（合理），您就应该避免使用它们。随着时间的推移，你会弄清楚什么时候是合理的。
• 在这种特殊情况下，很难看出如何去做（见续文中的

  When using an array...

  ）。

应用.匹配

• 当使用简单数据类型作为

  Application.Match

  中的第一个参数时，结果将始终是数字或错误值（错误2042）。用以下方法测试结果：

  If IsNumeric(Application.Match(filter_Criteria(i), subStrings, 0)) Then
  

  这与该问题的第一个发布答案中的内容相似。

• 当在

  Application.Match

  中使用数组或范围作为第一个参数时，结果将始终是数字和/或错误值的基于一的数组（一维或二维）。您可以使用

  Application.Count

  来计算（或检查）匹配项，从而避免循环并且不必担心有关数组的初始部分：

  With Application
      If .Count(.Match(filter_Criteria, subStrings, 0)) > 0 Then
          If Not...
              '''
          End If
      End If 
  End With
  

Answer 2

如果您需要按单元格包含任何条件数组元素进行过滤，请尝试下一个改编代码。它假设您需要在第一列 (A:A) 上进行过滤：

Sub AutoFilter_With_Multiple_Criteria()

    Const filter_Column As Long = 1 'column A:A
    
    Dim filter_Criteria() As Variant: filter_Criteria = Array("*Cathodic Protection*", "*C.P*", "*Riser*") 'changed array to avoid exact matches!
    
    Dim ws As Worksheet:    Set ws = ActiveSheet
    
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    Dim rg As Range
    Set rg = ws.UsedRange.Resize(ws.UsedRange.rows.count - 1).Offset(1) 'the source range (UsedRange except the first Row)

    Dim rCount As Long, arr() As Variant, El
    rCount = rg.rows.count - 1
    arr = rg.Columns(filter_Column).Resize(rCount).Offset(1).Value     'Write the values from criteria column to an array.
        
    Dim dict As New scripting.Dictionary                               'Write the matching strings to the keys (a 1D array) of a dictionary.
    
    Dim r As Long
    
    For r = 1 To rCount                                               'Loop through the elements of the array.
        If Len(arr(r, 1)) > 0 Then                                    'is not blank
            For Each El In filter_Criteria
                If arr(r, 1) Like El Then dict(arr(r, 1)) = vbNullString: Exit For
            Next El
        End If
    Next r
    
    If dict.count > 0 Then
        rg.AutoFilter field:=filter_Column, Criteria1:=dict.keys, Operator:=xlFilterValues   'use the keys of the dictionary (a 1D array) as a Criteria
    End If
    
End Sub

Answer 3

问题是此行中的类型不匹配，由“Application.Match”未返回布尔值引起。

If Application.Match(filter_Criteria(i), subStrings, 0) Then

所以你需要这样重写它：

If Not IsError(Application.Match(filter_Criteria(i), subStrings, 0)) Then