基于VBA实现两个单元格相似字符串序列的彩色高亮需求

需求概述 #

需要对比Excel两个单元格中的文本序列，自动识别并高亮相似片段，同时解决现有方案的两个核心问题：

• 优先匹配最长连续相似序列，避免拆分高亮短片段
• 仅高亮独立单字符（单字符前需为空格或单元格开头），杜绝误匹配单词内部字符

示例场景 #

场景1：完整连续匹配
单元格1：ADSGPINDTDANPR
单元格2：RGTELDDGIQADSGPINDTDANPRY VPGYY ESQSDDPHFHEK
预期：两个单元格中的ADSGPINDTDANPR均高亮

场景2：带间隔的分段匹配
单元格1：LADNS TFDDDLDDLTPSKMKPANFKGD
单元格2：RSLA FDDDLDDLTPSRGXKMKPANFKGDYG
预期：单元格1的LA、FDDDLDDLTPSKMKPANFKGD，单元格2的LA、FDDDLDDLTPS、KMKPANFKGD分别高亮

修正场景：避免错误高亮
单元格1：SKP ERYSG
单元格2：TAPGEQAQD
预期：无任何高亮（P、G为单词内部字符，不满足独立条件）

VBA 实现代码 #

Sub HighlightMatchingSequences()
    Dim rng1 As Range, rng2 As Range
    Dim txt1 As String, txt2 As String
    Dim matches As Collection
    Dim matchItem As Variant
    Dim i As Long, j As Long, maxLen As Long
    Dim startPos As Long, endPos As Long, subStr As String, currChar As String
    
    ' 自定义目标单元格（可根据实际修改）
    Set rng1 = Range("A1")
    Set rng2 = Range("B1")
    
    ' 清除原有格式与占位符
    rng1.ClearFormats
    rng2.ClearFormats
    txt1 = rng1.Value
    txt2 = rng2.Value
    
    Set matches = New Collection
    
    ' --- 步骤1：优先匹配最长连续序列（长度≥2）---
    maxLen = Application.Min(Len(txt1), Len(txt2))
    For i = maxLen To 2 Step -1
        For j = 1 To Len(txt1) - i + 1
            subStr = Mid(txt1, j, i)
            If Not IsInCollection(matches, subStr) Then
                startPos = InStr(txt2, subStr)
                If startPos > 0 Then
                    matches.Add Array(subStr, "long", j, startPos)
                    ' 标记已匹配区域，避免短序列重复匹配
                    txt1 = Replace(txt1, subStr, String(i, Chr(0)))
                    txt2 = Replace(txt2, subStr, String(i, Chr(0)))
                End If
            End If
        Next j
    Next i
    
    ' --- 步骤2：匹配符合条件的独立单字符 ---
    For i = 1 To Len(rng1.Value)
        currChar = Mid(rng1.Value, i, 1)
        ' 判断是否为独立字符：前为空格/开头，后为空格/结尾
        If (i = 1 Or Mid(rng1.Value, i - 1, 1) = " ") And _
           (i = Len(rng1.Value) Or Mid(rng1.Value, i + 1, 1) = " ") Then
            ' 在单元格2中查找独立的该字符
            startPos = InStr(rng2.Value, " " & currChar & " ")
            If startPos = 0 Then
                ' 检查是否位于单元格开头或结尾
                startPos = IIf(Left(rng2.Value, 1) = currChar, 1, 0)
                If startPos = 0 Then
                    startPos = IIf(Right(rng2.Value, 1) = currChar, Len(rng2.Value), 0)
                End If
            Else
                startPos = startPos + 1 ' 跳过前面的空格
            End If
            If startPos > 0 And Not IsInCollection(matches, currChar) Then
                matches.Add Array(currChar, "single", i, startPos)
            End If
        End If
    Next i
    
    ' --- 步骤3：执行高亮操作 ---
    txt1 = rng1.Value
    txt2 = rng2.Value
    
    For Each matchItem In matches
        matchStr = matchItem(0)
        pos1 = matchItem(2)
        pos2 = matchItem(3)
        
        ' 高亮单元格1的匹配片段
        With rng1.Characters(pos1, Len(matchStr))
            .Font.ColorIndex = 0
            .Interior.Color = vbYellow
        End With
        
        ' 高亮单元格2的匹配片段
        With rng2.Characters(pos2, Len(matchStr))
            .Font.ColorIndex = 0
            .Interior.Color = vbYellow
        End With
    Next matchItem
End Sub

' 辅助函数：检查字符串是否已在集合中，避免重复匹配
Function IsInCollection(col As Collection, str As String) As Boolean
    Dim item As Variant
    On Error Resume Next
    item = col(str)
    IsInCollection = (Err.Number = 0)
    On Error GoTo 0
End Function

代码说明 #

1. 最长序列优先：从最长可能的子串开始遍历匹配，匹配后用占位符标记已覆盖区域，彻底解决短序列拆分高亮的问题
2. 独立字符校验：通过检查字符前后的空格（或单元格首尾位置），确保仅高亮符合要求的独立单字符，避免误匹配单词内部字符
3. 格式替换：清除原有加粗斜体格式，统一用黄色背景高亮匹配片段，直观清晰

使用方法 #

1. 打开Excel，按下Alt + F11打开VBA编辑器
2. 插入新模块，粘贴上述代码
3. 修改代码中rng1和rng2的目标单元格（如Range("C2")、Range("D2")）
4. 运行HighlightMatchingSequences宏即可

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