Excel正则匹配带/不带撇号关键词并排除引号的技术问询

需求说明 #

• 需在Excel工作簿中，将关键词列与另一表格文本列拼接成的长字符串（ConcatenatedString，单条文本长度≥2000字符）进行匹配
• 关键词规则：
  • 含撇号（如isn't a problem）与不含撇号（如dont recommend）的同类关键词需互相匹配（dont ↔ don't）
  • 被双引号包裹的关键词，匹配时需忽略双引号
• 优化要求：改进现有代码的匹配逻辑，改用二维数组存储所有匹配结果后批量输出到结果表格，提升处理效率（共819个关键词）

优化后的完整VBA代码 #

Sub MatchKeywordsWithOptimizations()
    Dim KeywordsRange As Range, keywordCell As Range
    Dim concatenatedString As String
    Dim wkOutput As Worksheet
    Dim regex As Object, matchCollection As Object, regexMatch As Object
    Dim keyword As String, cleanKeyword As String
    Dim resultsArr() As Variant, resultCount As Long
    
    ' 初始化正则对象（启用全局匹配，忽略大小写可按需调整）
    Set regex = CreateObject("VBScript.RegExp")
    regex.Global = True
    regex.IgnoreCase = True ' 需区分大小写则设为False
    
    ' 此处需自行补充：KeywordsRange、concatenatedString、wkOutput的赋值
    ' 示例：Set KeywordsRange = Sheets("关键词表").Range("A2:A820")
    ' 示例：concatenatedString = Join(Sheets("文本表").Range("B2:B1000").Value, vbCrLf)
    ' 示例：Set wkOutput = Sheets("匹配结果")
    
    ' 初始化结果数组，预分配足够空间
    ReDim resultsArr(1 To 10000, 1 To 3)
    resultCount = 0
    
    For Each keywordCell In KeywordsRange
        keyword = Trim(keywordCell.Value)
        If keyword = "" Then GoTo NextKeyword ' 跳过空关键词
        
        ' 处理双引号包裹的关键词
        If Left(keyword, 1) = """" And Right(keyword, 1) = """" Then
            cleanKeyword = Mid(keyword, 2, Len(keyword) - 2)
        Else
            cleanKeyword = keyword
        End If
        
        ' 构建正则模式：实现撇号可选匹配，覆盖带/不带撇号的情况
        Dim pattern As String
        pattern = "\b" & Replace(cleanKeyword, "'", "'?") & "\b"
        ' 补充无撇号关键词匹配带撇号版本的分支（针对dont→don't这类场景）
        If InStr(cleanKeyword, "'") = 0 Then
            pattern = pattern & "|\b" & Replace(cleanKeyword, "n t", "n't") & "\b"
        End If
        
        regex.pattern = pattern
        
        ' 执行匹配
        Set matchCollection = regex.Execute(concatenatedString)
        
        ' 收集匹配结果到数组
        For Each regexMatch In matchCollection
            resultCount = resultCount + 1
            ' 数组空间不足时动态扩容
            If resultCount > UBound(resultsArr, 1) Then
                ReDim Preserve resultsArr(1 To resultCount + 5000, 1 To 3)
            End If
            ' 替换为实际的受访者信息获取逻辑，原代码SubMatches需正则分组支持
            resultsArr(resultCount, 1) = "受访者信息" 
            resultsArr(resultCount, 2) = regexMatch.Value ' 匹配到的文本
            resultsArr(resultCount, 3) = cleanKeyword ' 清洗后的原始关键词
        Next regexMatch
        
NextKeyword:
    Next keywordCell
    
    ' 批量写入结果到输出表格
    If resultCount > 0 Then
        ' 清空原有结果（可选）
        wkOutput.Range("A2:C" & wkOutput.Cells(wkOutput.Rows.Count, 1).End(xlUp).Row).ClearContents
        ' 写入数组内容
        wkOutput.Range("A2").Resize(resultCount, 3).Value = resultsArr
    Else
        MsgBox "未找到匹配结果"
    End If
    
    ' 释放对象
    Set regex = Nothing
    Set matchCollection = Nothing
    Set KeywordsRange = Nothing
    Set wkOutput = Nothing
End Sub

关键优化说明 #

• 撇号匹配逻辑：将关键词中的撇号处理为可选匹配（'?），同时补充无撇号关键词匹配带撇号版本的分支，确保同类关键词互相匹配
• 双引号处理：准确识别并移除关键词首尾的双引号，避免干扰正则匹配
• 数组存储优化：用二维数组批量存储所有匹配结果，最后一次性写入表格，避免循环写入单元格的IO开销，大幅提升819个关键词场景下的处理效率
• 正则增强：启用全局匹配确保找到所有匹配项，使用单词边界\b避免部分误匹配

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