VBA单词匹配高亮代码准确率不足，请求技术协助

我编写了一段用于识别匹配单词并高亮对应内容的VBA代码，尝试运行后发现无法达到100%的准确率，恳请各位技术人士帮忙排查问题并优化。

示例数据说明 #

• Sheet1的A列包含待检测的文本内容
• Sheet2的A列是需要匹配的目标单词列表

原代码 #

Sub HighlightMatchingWords()
    Dim lastRowSheet1 As Long
    Dim lastRowSheet2 As Long
    Dim i As Long
    Dim j As Long
    Dim cellValueSheet1 As String
    Dim cellValueSheet2 As String
    Dim wordsSheet1 As Variant
    Dim wordsSheet2 As Variant
    Dim wordIndexSheet1 As Long
    Dim wordIndexSheet2 As Long
    Dim wordSheet1 As String
    Dim wordSheet2 As String
    
    ' 获取Sheet1中A列的最后一行数据
    lastRowSheet1 = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, 1).End(xlUp).Row
    
    ' 获取Sheet2中A列的最后一行数据
    lastRowSheet2 = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, 1).End(xlUp).Row
    
    ' 遍历Sheet1中A列的每一行数据
    For i = 1 To lastRowSheet1
        ' 获取Sheet1当前行A列的值
        cellValueSheet1 = Sheets("Sheet1").Cells(i, 1).Value
    
        ' 将Sheet1的字符串按空格拆分为单词数组
        wordsSheet1 = Split(cellValueSheet1, " ")
    
        ' 遍历Sheet2中A列的每一行数据
        For j = 1 To lastRowSheet2
            ' 获取Sheet2当前行A列的值
            cellValueSheet2 = Sheets("Sheet2").Cells(j, 1).Value
    
            ' 将Sheet2的字符串按空格拆分为单词数组
            wordsSheet2 = Split(cellValueSheet2, " ")
    
            ' 遍历Sheet1拆分后的每个单词
            For wordIndexSheet1 = 0 To UBound(wordsSheet1)
                ' 遍历Sheet2拆分后的每个单词
                For wordIndexSheet2 = 0 To UBound(wordsSheet2)
                    ' 如果单词匹配，高亮Sheet1中的对应单词
                    If StrComp(wordsSheet1(wordIndexSheet1), wordsSheet2(wordIndexSheet2), vbTextCompare) = 0 Then
                        wordSheet1 = wordsSheet1(wordIndexSheet1)
                        ' 高亮Sheet1中的单词为红色
                        Sheets("Sheet1").Cells(i, 1).Characters(InStr(cellValueSheet1, wordSheet1), Len(wordSheet1)).Font.ColorIndex = 3
                        Sheets("Sheet1").Cells(i, 2).Value = Sheets("Sheet1").Cells(i, 2).Value & " " & word
                    End If
                Next wordIndexSheet2
            Next wordIndexSheet1
        Next j
    Next i
End Sub

原代码存在的问题 #

• 单词拆分逻辑缺陷：仅用空格拆分单词，无法处理标点（如apple,和apple会被视为不同单词）、多个连续空格、制表符等情况，导致匹配遗漏。
• 重复匹配处理不当：InStr只会定位到第一个匹配的单词，同一单元格内重复出现的匹配单词无法被高亮；同时多次匹配会重复写入Sheet1的B列，造成冗余内容。
• 未定义变量错误：代码中Sheets("Sheet1").Cells(i, 2).Value = ... & word里的word变量未定义，实际应为wordSheet1，会导致运行报错。
• 嵌套循环效率极低：四层嵌套循环在数据量较大时，运行速度会非常慢，且容易重复处理相同匹配。
• 匹配精度不足：仅通过大小写不敏感匹配，未处理单词前后的非字母数字字符，导致部分带标点的目标单词无法匹配。

优化后的代码 #

Sub HighlightMatchingWords_optimized()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim matchWords As Collection
    Dim cell As Range
    Dim regEx As Object
    Dim match As Object, matches As Object
    Dim matchedWords As Collection
    Dim word As Variant
    
    ' 初始化工作表对象
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    Set matchWords = New Collection
    Set regEx = CreateObject("VBScript.RegExp")
    
    ' 配置正则：匹配完整单词，忽略大小写，自动过滤标点
    regEx.Global = True
    regEx.IgnoreCase = True
    regEx.Pattern = "\b(\w+)\b" ' 匹配字母数字组成的独立单词
    
    ' 将Sheet2的单词存入集合并去重，避免重复匹配
    lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
    On Error Resume Next
    For Each cell In ws2.Range("A1:A" & lastRow2)
        If Trim(cell.Value) <> "" Then
            matchWords.Add Trim(cell.Value), Key:=UCase(Trim(cell.Value)) ' 用大写做键实现去重
        End If
    Next cell
    On Error GoTo 0
    
    ' 处理Sheet1的每个单元格
    lastRow1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
    For Each cell In ws1.Range("A1:A" & lastRow1)
        If cell.Value <> "" Then
            ' 重置当前单元格的字体颜色和匹配单词集合
            cell.Font.ColorIndex = xlAutomatic
            Set matchedWords = New Collection
            
            ' 用正则提取当前单元格的所有独立单词
            Set matches = regEx.Execute(cell.Value)
            For Each match In matches
                On Error Resume Next
                word = match.SubMatches(0)
                ' 检查单词是否在匹配列表中
                If matchWords(UCase(word)) <> "" Then
                    ' 记录已匹配的单词，避免重复写入B列
                    matchedWords.Add word, Key:=UCase(word)
                    
                    ' 高亮当前单元格内所有匹配的单词
                    Dim pos As Long
                    pos = 1
                    Do
                        pos = InStr(pos, cell.Value, word, vbTextCompare)
                        If pos > 0 Then
                            cell.Characters(pos, Len(word)).Font.ColorIndex = 3 ' 红色高亮
                            pos = pos + Len(word)
                        End If
                    Loop While pos > 0
                End If
                On Error GoTo 0
            Next match
            
            ' 将去重后的匹配单词写入B列
            If matchedWords.Count > 0 Then
                Dim resultStr As String
                resultStr = ""
                For Each word In matchedWords
                    resultStr = resultStr & " " & word
                Next word
                cell.Offset(0, 1).Value = Trim(resultStr)
            Else
                cell.Offset(0, 1).Value = ""
            End If
        Else
            cell.Offset(0, 1).Value = ""
        End If
    Next cell
    
    ' 释放对象
    Set regEx = Nothing
    Set matchWords = Nothing
    Set matchedWords = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
End Sub

优化说明 #

1. 正则表达式匹配：使用\b(\w+)\b匹配完整单词，自动忽略标点、连续空格等干扰，确保只匹配独立的单词。
2. 集合去重存储：将Sheet2的单词存入集合并自动去重，避免重复处理相同单词，大幅提升匹配效率。
3. 全匹配高亮：通过循环InStr定位单元格内所有匹配的单词，实现重复单词的全部高亮。
4. 匹配结果去重写入：用集合记录已匹配的单词，避免B列出现重复内容。
5. 代码结构优化：减少嵌套层级，使用工作表对象简化代码，提升可读性和运行效率。
6. 修复变量错误：修正原代码中未定义变量的问题，确保代码正常运行。

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