vba - 按字符比较(差异)两个单元格中的字符串

Question

我在两个不同文本的单元格中有文本。我正在尝试识别两个单元格之间的差异(文本之间的差异:添加或丢失的文本)

1. 在A1我有一段文字。
2. B1 包含一个相似的段落，但存在细微差别。

我正在尝试识别这些字符串之间的区别，请帮助我使用 VBA 识别带有颜色的 单元格中的那些区别

Answer 1

我有解决您问题的方法，并且已经上传了包含您的示例字符串对的工作簿。这是 workbook .

我的代码基于 Needleman–Wunsch algorithm ，它于 1970 年首次开发，至今仍在科学技术中用于比对 DNA 序列。但是，我修改了算法并添加了额外的后处理以处理您的示例数据字符串对。

这里是如何工作的过程。在 A1 和 A2 中输入要比较的两个字符串。

按 Alt-F8 并运行宏 AlignStrings。

结果将显示在单元格 A5 和 A6 中。

请注意，其他示例字符串对可以在工作表的下方找到，从单元格 A21 开始。

下面是工作簿中完成字符串对对齐和差异突出显示的代码:

Public Sub AlignStrings()
    Dim a() As Byte, b() As Byte, a_$, b_$, i&, j&, d&, u&, l&, x&, y&, f&()
    Const GAP = -1
    Const PAD = "_"

    a = [a1].Text: b = [a2].Text
    [a3:a6].Clear
    [a1:a6].Font.Name = "Courier New"

    ReDim f(0 To UBound(b) \ 2 + 1, 0 To UBound(a) \ 2 + 1)

    For i = 1 To UBound(f, 1)
        For j = 1 To UBound(f, 2)
            x = j - 1: y = i - 1
            If a(x * 2) = b(y * 2) Then
                d = 1 + f(y, x)
                u = 0 + f(y, j)
                l = 0 + f(i, x)
            Else
                d = -1 + f(y, x)
                u = GAP + f(y, j)
                l = GAP + f(i, x)
            End If
            f(i, j) = Max(d, u, l)
        Next
    Next

    i = UBound(f, 1): j = UBound(f, 2)
    On Error Resume Next
    Do
        x = j - 1: y = i - 1
        d = f(y, x)
        u = f(y, j)
        l = f(i, x)
        Select Case True
            Case Err
                If y < 0 Then GoTo left Else GoTo up
            Case d >= u And d >= l Or Mid$(a, j, 1) = Mid$(b, i, 1)
diag:
                a_ = Mid$(a, j, 1) & a_
                b_ = Mid$(b, i, 1) & b_
                i = i - 1: j = j - 1
            Case u > l
up:
                a_ = PAD & a_
                b_ = Mid$(b, i, 1) & b_
                i = i - 1
            Case l > u
left:
                a_ = Mid$(a, j, 1) & a_
                b_ = PAD & b_
                j = j - 1
        End Select
    Loop Until i < 1 And j < 1

    DecorateStrings a_, b_, [a5], [a6], PAD

End Sub


Private Function Max(a&, b&, c&) As Long
    Max = a
    If b > a Then Max = b
    If c > b Then Max = c
End Function


Private Sub DecorateStrings(a$, b$, rOutA As Range, rOutB As Range, PAD$)
    Dim i&, j&

    FloatArtifacts a, b, PAD
    FloatArtifacts b, a, PAD

    rOutA = a
    rOutB = b

    For i = 1 To Len(a)
        If Mid$(a, i, 1) <> Mid$(b, i, 1) Then
            If Mid$(a, i, 1) <> PAD Then
                rOutA.Characters(i, 1).Font.Color = vbRed
            End If
        End If
    Next
    For i = 1 To Len(b)
        If Mid$(a, i, 1) <> Mid$(b, i, 1) Then
            If Mid$(b, i, 1) <> PAD Then
                rOutB.Characters(i, 1).Font.Color = vbRed
            End If
        End If
    Next

End Sub


Private Sub FloatArtifacts(s1$, s2$, PAD$)
    Dim c&, k&, i&, p&
    For i = 1 To Len(s1)
        c = InStr(i, s1, PAD)
        If c Then
            k = 0
            Do
                k = k + 1
                If Mid$(s1, c + k, 1) <> PAD Then
                    If Mid$(s2, c, 1) = Mid$(s1, c + k, 1) Then
                        p = InStr(c + k, s1, PAD)
                        If p < (c + k + 6) And p > 0 Then
                            Mid$(s1, c, 1) = Mid$(s1, c + k, 1)
                            Mid$(s1, c + k, 1) = PAD
                            i = c
                            Exit Do
                        Else
                            i = c + k
                            Exit Do
                        End If
                    Else
                        i = c + k
                        Exit Do
                    End If
                End If
                If c + k > Len(s1) Then Exit Do
            Loop
        Else
            Exit For
        End If
    Next
End Sub