按字符比较（比较）两个单元格中的string

我有两个不同文本的单元格中的文本。 我试图找出两个单元格之间的差异（文本之间的差异：添加或丢失的文本）

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

我试图找出这些string之间的区别，请帮助我使用VBA来识别这两个单元格之间的差异

Answer 1

我有你的问题的解决scheme，并与您的示例string对上传工作簿。 这是工作簿 。

我的代码基于Needleman-Wunschalgorithm ，该algorithm于1970年首次开发，目前仍然用于在科学技术中alignmentDNA序列。 不过，我修改了algorithm，并添加了额外的后处理，以处理您的示例数据string对。

这是如何工作的过程。 input你的两个string来比较A1和A2。

按Alt-F8并运行macros， AlignStrings 。

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

请注意，其他样本string对可以从单元格A21开始进一步向下find。

下面是工作簿中完成stringalignment和高亮区别的代码：

 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