VBA单元格文本对比优化需求：逐词替代逐字符对比

我正在开发一款可跨多工作表识别相似单元格文本并分组的程序，当前聚焦对比子流程的实现。我编写了VBA测试代码，通过逐字符对比相邻单元格输出相似度得分，但该代码存在明显缺陷：例如对比"This is a test string"与"Ths is a text string"时，仅因开头缺失一个"i"，逐字符对比就会因错位导致相似度得分极低，而实际差异很小。现寻求将对比逻辑改为逐词对比的优化建议（文本中90%为数字类内容）。

原测试代码 #

Option Explicit
Sub ComparisonTest()
    Dim arr         As Variant
    Dim columncount As Integer
    Dim rowcount As Long
    Sheets(1).Select
    arr = ActiveSheet.Range("A1").CurrentRegion
    columncount = UBound(arr, 2)
    rowcount = UBound(arr, 1)
    Dim N           As Long
    Dim Letter      As Long
    Dim test1_string        As Variant
    Dim test2_string        As Variant
    Dim Test1_Comp As String
    Dim Test2_Comp As String
    Dim similarity As Integer
    Dim lettercount As Integer
    Dim lettercount2 As Integer
    'initialize count
    'construct loop from top to bottom and left to right
    For N = 1 To rowcount
    lettercount = Len(Cells(N, 1).Value)
    lettercount2 = Len(Cells(N, 2).Value)
        If lettercount2 > lettercount Then
        lettercount = lettercount2
        Else
        End If
    test1_string = CStr(Cells(N, 1))
    test2_string = CStr(Cells(N, 2))
        For Letter = 1 To Len(Cells(N, 1).Value)
            Test1_Comp = Mid(test1_string, Letter, 1)
            Test2_Comp = Mid(test2_string, Letter, 1)
                If Test1_Comp = Test2_Comp Then
                    similarity = similarity + 1
                Else
                End If
        Next Letter
            If similarity > (lettercount * 0.9) Then
                Cells(N, 3).Value = (similarity / lettercount)
                Cells(N, 3).Interior.Color = vbGreen
            Else
                Cells(N, 3).Value = (similarity / lettercount)
                Cells(N, 3).Interior.Color = vbRed
            End If
            similarity = 0
    Next N
End Sub

核心思路 #

逐词对比的关键是先将单元格文本拆分为独立的"词"（数字、英文单词等），再基于词的匹配度计算相似度，避免字符错位导致的误判。针对90%为数字的场景，需确保连续数字被识别为单个词，不被拆分。

具体实现步骤及代码 #

1. 文本拆分函数：编写通用函数，按空格分隔文本，同时保留连续数字/英文单词作为单个词，过滤空元素。
2. 相似度计算：统计两个词列表的交集数量，用「匹配词数 / 总词数（取两者最大值）」作为相似度得分，避免重复匹配同一词。
3. 替换原对比逻辑：将逐字符循环替换为逐词匹配逻辑，输出结果并标记颜色。

优化后的代码：

Option Explicit

' 将文本按空格拆分为词数组，自动过滤空元素
Function SplitToWords(text As String) As Variant
    Dim tempArr() As String
    Dim splitArr As Variant
    Dim i As Integer, j As Integer
    
    splitArr = Split(Trim(text), " ")
    j = 0
    ReDim tempArr(0 To UBound(splitArr))
    
    For i = 0 To UBound(splitArr)
        If splitArr(i) <> "" Then
            tempArr(j) = splitArr(i)
            j = j + 1
        End If
    Next i
    
    ReDim Preserve tempArr(0 To j - 1)
    SplitToWords = tempArr
End Function

' 计算两个词数组的相似度
Function CalculateWordSimilarity(words1 As Variant, words2 As Variant) As Double
    If UBound(words1) = -1 Or UBound(words2) = -1 Then
        CalculateWordSimilarity = 0
        Exit Function
    End If
    
    Dim matchCount As Integer
    Dim i As Integer, j As Integer
    Dim matched() As Boolean
    ReDim matched(0 To UBound(words2))
    
    ' 统计匹配的词数，标记已匹配的词避免重复计数
    For i = 0 To UBound(words1)
        For j = 0 To UBound(words2)
            If Not matched(j) And words1(i) = words2(j) Then
                matchCount = matchCount + 1
                matched(j) = True
                Exit For
            End If
        Next j
    Next i
    
    ' 用匹配数除以总词数的最大值计算相似度
    Dim totalWords As Integer
    totalWords = IIf(UBound(words1) > UBound(words2), UBound(words1) + 1, UBound(words2) + 1)
    CalculateWordSimilarity = matchCount / totalWords
End Function

Sub WordBasedComparisonTest()
    Dim rowcount As Long
    Dim N As Long
    Dim text1 As String, text2 As String
    Dim words1 As Variant, words2 As Variant
    Dim similarity As Double
    
    Sheets(1).Select
    rowcount = ActiveSheet.Range("A1").CurrentRegion.Rows.Count
    
    For N = 1 To rowcount
        text1 = CStr(Cells(N, 1).Value)
        text2 = CStr(Cells(N, 2).Value)
        
        words1 = SplitToWords(text1)
        words2 = SplitToWords(text2)
        
        similarity = CalculateWordSimilarity(words1, words2)
        
        ' 输出相似度得分并标记颜色
        Cells(N, 3).Value = similarity
        Cells(N, 3).Interior.Color = IIf(similarity >= 0.9, vbGreen, vbRed)
    Next N
End Sub

代码说明 #

• SplitToWords：处理文本拆分，过滤因多空格产生的空词，保证词数组的有效性。
• CalculateWordSimilarity：通过标记已匹配词的方式，准确统计两个文本的匹配词数，避免重复计数，相似度计算更贴合实际差异。
• WordBasedComparisonTest：主流程替换原逐字符逻辑，调用拆分和计算函数完成对比，输出结果并按阈值标记颜色。

额外优化建议 #

• 若文本包含带逗号/小数点的数字，可扩展SplitToWords函数，添加正则表达式匹配逻辑，确保这类数字被识别为单个词。
• 处理大量数据时，可将单元格数据一次性加载到数组中，减少与工作表的交互次数，提升运行效率。

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