如何同时遍历数组所有元素？精简VBA多条件判断代码需求

问题场景 #

当前代码需要校验数组元素arr(r, 1)不包含filter_Criteria中的任何值，但只能通过逐个编写InStr判断的方式实现，希望精简这段重复的校验逻辑。原判断代码如下：

If InStr(arr(r, 1), filter_Criteria(0)) = 0 And _
   InStr(arr(r, 1), filter_Criteria(1)) = 0 And _
   InStr(arr(r, 1), filter_Criteria(2)) = 0 Then

完整原代码：

Sub Loop_Array_at_the_same_time()
    
    Dim filter_Criteria() As Variant, dict As Object, arr, r As Long
    
    filter_Criteria = Array("A", "B", "C")
    
    arr = Application.Transpose(Range("B2", Cells(Rows.Count, "B").End(xlUp)))
   
    Set dict = CreateObject("Scripting.Dictionary")

    For r = 1 To UBound(arr)
    
         If InStr(arr(r, 1), filter_Criteria(0)) = 0 And _
            InStr(arr(r, 1), filter_Criteria(1)) = 0 And _
            InStr(arr(r, 1), filter_Criteria(2)) = 0 Then
               
            dict(arr(r, 1)) = vbNullString
                 
         End If
        
    Next r
    
End Sub 

优化方案 #

方案1：内部循环遍历校验数组

通过新增内部循环遍历filter_Criteria数组，用标志位记录是否匹配到关键词，避免重复编写InStr判断，同时适配任意长度的过滤数组：

Sub Loop_Array_at_the_same_time()
    
    Dim filter_Criteria() As Variant, dict As Object, arr, r As Long
    Dim matchFound As Boolean, criteria As Variant
    
    filter_Criteria = Array("A", "B", "C")
    
    arr = Application.Transpose(Range("B2", Cells(Rows.Count, "B").End(xlUp)))
   
    Set dict = CreateObject("Scripting.Dictionary")

    For r = 1 To UBound(arr)
        matchFound = False ' 初始化匹配标志
        ' 遍历所有过滤条件
        For Each criteria In filter_Criteria
            If InStr(arr(r, 1), criteria) > 0 Then
                matchFound = True
                Exit For ' 找到匹配后提前退出循环，提升效率
            End If
        Next criteria
        
        ' 未匹配任何条件时将元素加入字典
        If Not matchFound Then
            dict(arr(r, 1)) = vbNullString
        End If
    Next r
    
End Sub 

后续新增过滤关键词时，只需修改filter_Criteria = Array(...)的内容，无需调整校验逻辑。

方案2：正则表达式批量匹配

如果过滤条件是简单字符串，可利用正则表达式的“或”语法批量匹配，代码更简洁：

Sub Loop_Array_with_Regex()
    
    Dim filter_Criteria() As Variant, dict As Object, arr, r As Long
    Dim regex As Object
    
    filter_Criteria = Array("A", "B", "C")
    
    arr = Application.Transpose(Range("B2", Cells(Rows.Count, "B").End(xlUp)))
    Set dict = CreateObject("Scripting.Dictionary")
    Set regex = CreateObject("VBScript.RegExp")
    
    ' 配置正则规则：匹配任意一个过滤关键词，如需区分大小写可去掉IgnoreCase
    regex.Pattern = Join(filter_Criteria, "|")
    regex.IgnoreCase = False

    For r = 1 To UBound(arr)
        ' 未匹配到任何关键词时加入字典
        If Not regex.Test(arr(r, 1)) Then
            dict(arr(r, 1)) = vbNullString
        End If
    Next r
    
End Sub 

正则的Test方法会直接返回是否匹配到任意关键词，适合规则简单的场景。

内容的提问来源于stack exchange，提问作者Peace