如何在Excel VBA中遍历单词列表并通过正则表达式进行匹配？

我有一个包含Sheet A和Sheet B的Excel工作簿：

• Sheet A是大量非结构化数据，需检查E列内容
• Sheet B的A列每行是1-4个单词的字符串（最多100条，数据从数据库动态获取，支持增删）

现有VBA代码原本是要找出Sheet A中E列包含Sheet B字符串的行，复制到Sheet C，但存在问题：

• 原代码仅匹配Sheet B字符串与Sheet A E列单元格完全相等的内容，无法检测"包含"的情况
• 需要实现：遍历Sheet A每一行时，匹配Sheet B所有字符串，只要E列包含任意一个就复制该行到Sheet C
• 另外考虑用正则表达式优化，可大幅缩短Sheet B的匹配列表

请问是否需要将Sheet B每个字符串存为变量用于正则匹配？或是有其他思路及代码编写方向？

原代码如下：

Sub Find()
 Dim sh1 As Worksheet, sh2 As Worksheet, rng As Range, cel As Range
 Dim rngCopy As Range, lastR1 As Long, lastR2 As Long
 Dim strSearch1 As String, strSearch2 As String
 Dim va, vb
 Dim i As Long
 Dim d As Object

 Set sh1 = ActiveSheet
 Set sh2 = Worksheets("SheetC")
 
 lastR1 = sh1.Range("E" & Rows.Count).End(xlUp).Row
 lastR2 = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
 
 With Sheets("SheetB")  'this is where the list is
    va = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
 End With
 
        Set d = CreateObject("scripting.dictionary")
        d.CompareMode = vbTextCompare
        For i = 1 To UBound(va, 1)
            d(va(i, 1)) = Empty
        Next
 
        vb = sh1.Range("E1:E" & lastR1)
        For i = 2 To UBound(vb, 1)
           If d.Exists(vb(i, 1)) Then
               If rngCopy Is Nothing Then
                   Set rngCopy = sh1.Rows(i)
               Else
                   Set rngCopy = Union(rngCopy, sh1.Rows(i))
               End If
           End If
        Next
 
    If Not rngCopy Is Nothing Then
       rngCopy.Copy Destination:=sh2.Cells(lastR2, 1)
    End If
End Sub

思路1：修正原逻辑，实现"包含"匹配（无需正则） #

原代码用字典做精确匹配，要改成"包含"匹配，只需遍历Sheet B的每个字符串，检查Sheet A E列单元格是否包含该字符串即可。这种方式适合Sheet B条目不多（最多100条）的场景，性能足够。

代码示例：

Sub FindAndCopy_MatchContains()
    Dim shA As Worksheet, shB As Worksheet, shC As Worksheet
    Dim lastRowA As Long, lastRowB As Long, lastRowC As Long
    Dim arrB As Variant, cellValue As String
    Dim i As Long, j As Long
    Dim rngCopy As Range
    
    ' 定义工作表对象
    Set shA = ActiveSheet ' 假设Sheet A是当前激活表
    Set shB = ThisWorkbook.Worksheets("SheetB")
    Set shC = ThisWorkbook.Worksheets("SheetC")
    
    ' 获取各表最后行号
    lastRowA = shA.Range("E" & shA.Rows.Count).End(xlUp).Row
    lastRowB = shB.Range("A" & shB.Rows.Count).End(xlUp).Row
    lastRowC = shC.Range("A" & shC.Rows.Count).End(xlUp).Row + 1
    
    ' 将Sheet B的匹配列表读入数组（提升效率）
    arrB = shB.Range("A1:A" & lastRowB).Value
    
    ' 遍历Sheet A的每一行（从第2行开始，假设第1行是表头）
    For i = 2 To lastRowA
        cellValue = shA.Range("E" & i).Value
        ' 遍历Sheet B的所有匹配字符串
        For j = 1 To UBound(arrB)
            ' 检查是否包含，忽略大小写
            If InStr(1, cellValue, arrB(j, 1), vbTextCompare) > 0 Then
                ' 标记要复制的行
                If rngCopy Is Nothing Then
                    Set rngCopy = shA.Rows(i)
                Else
                    Set rngCopy = Union(rngCopy, shA.Rows(i))
                End If
                Exit For ' 找到匹配后就不用再检查其他字符串了
            End If
        Next j
    Next i
    
    ' 批量复制到Sheet C
    If Not rngCopy Is Nothing Then
        rngCopy.Copy Destination:=shC.Cells(lastRowC, 1)
    End If
    
    ' 释放对象
    Set rngCopy = Nothing
    Set shA = Nothing
    Set shB = Nothing
    Set shC = Nothing
End Sub

思路2：使用正则表达式优化（适合大幅缩短匹配列表） #

如果Sheet B的匹配字符串可以合并为正则规则（比如多个相似字符串用通配符/分组），可以用正则提升效率，尤其是当匹配规则能大幅简化时。

实现步骤： #

1. 将Sheet B的字符串整理成正则匹配模式（比如用|分隔多个匹配项，实现"或"匹配）
2. 编译正则表达式，设置忽略大小写等选项
3. 遍历Sheet A E列，用正则检查是否匹配

代码示例：

Sub FindAndCopy_Regex()
    Dim shA As Worksheet, shB As Worksheet, shC As Worksheet
    Dim lastRowA As Long, lastRowB As Long, lastRowC As Long
    Dim arrB As Variant, regexPattern As String
    Dim i As Long
    Dim rngCopy As Range
    Dim regex As Object
    
    ' 定义工作表对象
    Set shA = ActiveSheet
    Set shB = ThisWorkbook.Worksheets("SheetB")
    Set shC = ThisWorkbook.Worksheets("SheetC")
    
    ' 获取行号
    lastRowA = shA.Range("E" & shA.Rows.Count).End(xlUp).Row
    lastRowB = shB.Range("A" & shB.Rows.Count).End(xlUp).Row
    lastRowC = shC.Range("A" & shC.Rows.Count).End(xlUp).Row + 1
    
    ' 构建正则模式：将Sheet B的每个字符串用|连接，实现"或"匹配
    arrB = shB.Range("A1:A" & lastRowB).Value
    For i = 1 To UBound(arrB)
        ' 转义正则特殊字符（比如. * +等），避免匹配异常
        regexPattern = regexPattern & "|" & EscapeRegex(arrB(i, 1))
    Next i
    ' 去掉开头的|
    regexPattern = Mid(regexPattern, 2)
    
    ' 创建正则对象并设置选项
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = regexPattern
    regex.IgnoreCase = True ' 忽略大小写
    regex.Global = False ' 只需匹配一次即可
    
    ' 遍历Sheet A
    For i = 2 To lastRowA
        If regex.Test(shA.Range("E" & i).Value) Then
            If rngCopy Is Nothing Then
                Set rngCopy = shA.Rows(i)
            Else
                Set rngCopy = Union(rngCopy, shA.Rows(i))
            End If
        End If
    Next i
    
    ' 复制到Sheet C
    If Not rngCopy Is Nothing Then
        rngCopy.Copy Destination:=shC.Cells(lastRowC, 1)
    End If
    
    ' 释放对象
    Set regex = Nothing
    Set rngCopy = Nothing
    Set shA = Nothing
    Set shB = Nothing
    Set shC = Nothing
End Sub

' 辅助函数：转义正则表达式中的特殊字符
Function EscapeRegex(str As String) As String
    Dim specialChars As Variant
    Dim char As Variant
    specialChars = Array("\", "^", "$", ".", "|", "?", "*", "+", "(", ")", "[", "]", "{", "}")
    For Each char In specialChars
        str = Replace(str, char, "\" & char)
    Next char
    EscapeRegex = str
End Function

思路对比 #

• 如果Sheet B的匹配字符串都是独立的、无法用正则简化，用思路1更直接，代码维护简单
• 如果匹配字符串可以用正则合并（比如要匹配"apple"、"apples"、"app"可以写成app(le(s)?)?），用思路2能大幅减少匹配条目，效率更高

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