在Excel中比较相似的文本字符串

你可以考虑使用 Microsoft Fuzzy Lookup Addin 。

来自MS网站。

概述

Excel的模糊查询插件是由Microsoft Research开发的，它可以在Microsoft Excel中执行文本数据的模糊匹配。它可用于识别单个表格内的模糊重复行，或模糊连接两个不同表格之间的类似行。该匹配对各种错误都很健全，包括拼写错误、缩写、同义词和添加/丢失的数据。例如，它可能会检测到 “Mr. Andrew Hill"、"Hill, Andrew R. "和 "Andy Hill "这几行都指的是同一个底层实体，并在每次匹配时返回一个相似度分数。虽然默认配置对于各种文本数据（如产品名称或客户地址）都能很好地工作，但也可以为特定的域或语言定制匹配。

我会考虑使用 this list (仅英文部分) 来帮助剔除常见的缩写。

另外，你可以考虑使用一个函数，它可以准确地告诉你两个字符串有多 “接近"。下面的代码来自 这里 ，感谢 smirkingman 。

Option Explicit
Public Function Levenshtein(s1 As String, s2 As String)

Dim i As Integer
Dim j As Integer
Dim l1 As Integer
Dim l2 As Integer
Dim d() As Integer
Dim min1 As Integer
Dim min2 As Integer

l1 = Len(s1)
l2 = Len(s2)
ReDim d(l1, l2)
For i = 0 To l1
    d(i, 0) = i
Next
For j = 0 To l2
    d(0, j) = j
Next
For i = 1 To l1
    For j = 1 To l2
        If Mid(s1, i, 1) = Mid(s2, j, 1) Then
            d(i, j) = d(i - 1, j - 1)
        Else
            min1 = d(i - 1, j) + 1
            min2 = d(i, j - 1) + 1
            If min2 < min1 Then
                min1 = min2
            End If
            min2 = d(i - 1, j - 1) + 1
            If min2 < min1 Then
                min1 = min2
            End If
            d(i, j) = min1
        End If
    Next
Next
Levenshtein = d(l1, l2)
End Function

这将告诉你，一个字符串必须插入和删除多少次才能到达另一个字符串。我会尽量把这个数字保持在较低的水平（姓氏应该准确）。

我有一个（很长的）公式，你可以使用。它不像上面那些公式那么完善–而且只适用于姓氏，而不是全名–但你可能会发现它很有用。

所以，如果你有一个标题行，想比较A2和B2，把这个放在该行的任何其他单元格中（例如，C2），然后复制到最后。

=IF(A2=B2, “EXACT”,IF(SUBSTITUTE(A2,“-”,“ ”)=SUBSTITUTE(B2,“-”,“ ”), “连字符”,IF(LEN(A2)>LEN(B2),IF(LEN(A2)>LEN(SUBSTITUTE(A2,B2,“”)), “全字符串”,IF(MID(A2,1, 1)=MID(B2,1,1),1,0)+IF(MID(A2,2,1)=MID(B2,2,1),1,0)+IF(MID(A2,3,1)=MID(B2,3,1),1,0)+IF(MID(A2,LEN(A2),1)=MID(B2,LEN(B2),1),1,0)+IF(MID(A2,LEN(A2)-1,1)=MID(B2,LEN(B2)-1,1),1, 0)+IF(MID(A2,LEN(A2)-2,1)=MID(B2,LEN(B2)-2,1),1,0)&“°”),IF(LEN(B2)>LEN(SUBSTITUTE(B2,A2,“”)), “整串”,IF(MID(A2,1,1)=MID(B2,1,1),1,0)+IF(MID(A2,2,1)=MID(B2,2,1),1, 0)+IF(MID(A2,3,1)=MID(B2,3,1),1,0)+IF(MID(A2,LEN(A2),1)=MID(B2,LEN(B2),1),1,0)+IF(MID(A2,LEN(A2),1)=MID(B2,LEN(B2)-2,1),1,0)&“°”))))。

这将返回。

• EXACT - 如果是完全匹配
• Hyphen - 如果是一对双杠名字，但其中一个有连字符，另一个有空格
• Whole string - 如果一个姓氏的所有部分都是另一个的一部分（例如，如果一个Smith变成了一个French-Smith）

之后，它将根据两者之间的比较点数量，给你一个0°到6°的度数。即6°比较好）。

正如我所说的，有点粗糙，但希望能让你在大致正确的球位上。

正在搜索类似的东西。我找到了下面的代码。我希望这对下一个来问这个问题的用户有帮助

Returns 91% for Abracadabra / Abrakadabra, 75% for Hollywood Street/Hollyhood Str, 62% for Florence/France and 0 for Disneyland

I’d say it’s close enough to what you wanted : )

Public Function Similarity(ByVal String1 As String, _
    ByVal String2 As String, _
    Optional ByRef RetMatch As String, _
    Optional min_match = 1) As Single
Dim b1() As Byte, b2() As Byte
Dim lngLen1 As Long, lngLen2 As Long
Dim lngResult As Long

If UCase(String1) = UCase(String2) Then
    Similarity = 1
Else:
    lngLen1 = Len(String1)
    lngLen2 = Len(String2)
    If (lngLen1 = 0) Or (lngLen2 = 0) Then
        Similarity = 0
    Else:
        b1() = StrConv(UCase(String1), vbFromUnicode)
        b2() = StrConv(UCase(String2), vbFromUnicode)
        lngResult = Similarity_sub(0, lngLen1 - 1, _
        0, lngLen2 - 1, _
        b1, b2, _
        String1, _
        RetMatch, _
        min_match)
        Erase b1
        Erase b2
        If lngLen1 >= lngLen2 Then
            Similarity = lngResult / lngLen1
        Else
            Similarity = lngResult / lngLen2
        End If
    End If
End If

End Function

Private Function Similarity_sub(ByVal start1 As Long, ByVal end1 As Long, _
                                ByVal start2 As Long, ByVal end2 As Long, _
                                ByRef b1() As Byte, ByRef b2() As Byte, _
                                ByVal FirstString As String, _
                                ByRef RetMatch As String, _
                                ByVal min_match As Long, _
                                Optional recur_level As Integer = 0) As Long
'* CALLED BY: Similarity *(RECURSIVE)

Dim lngCurr1 As Long, lngCurr2 As Long
Dim lngMatchAt1 As Long, lngMatchAt2 As Long
Dim I As Long
Dim lngLongestMatch As Long, lngLocalLongestMatch As Long
Dim strRetMatch1 As String, strRetMatch2 As String

If (start1 > end1) Or (start1 < 0) Or (end1 - start1 + 1 < min_match) _
Or (start2 > end2) Or (start2 < 0) Or (end2 - start2 + 1 < min_match) Then
    Exit Function '(exit if start/end is out of string, or length is too short)
End If

For lngCurr1 = start1 To end1
    For lngCurr2 = start2 To end2
        I = 0
        Do Until b1(lngCurr1 + I) <> b2(lngCurr2 + I)
            I = I + 1
            If I > lngLongestMatch Then
                lngMatchAt1 = lngCurr1
                lngMatchAt2 = lngCurr2
                lngLongestMatch = I
            End If
            If (lngCurr1 + I) > end1 Or (lngCurr2 + I) > end2 Then Exit Do
        Loop
    Next lngCurr2
Next lngCurr1

If lngLongestMatch < min_match Then Exit Function

lngLocalLongestMatch = lngLongestMatch
RetMatch = ""

lngLongestMatch = lngLongestMatch _
+ Similarity_sub(start1, lngMatchAt1 - 1, _
start2, lngMatchAt2 - 1, _
b1, b2, _
FirstString, _
strRetMatch1, _
min_match, _
recur_level + 1)
If strRetMatch1 <> "" Then
    RetMatch = RetMatch & strRetMatch1 & "*"
Else
    RetMatch = RetMatch & IIf(recur_level = 0 _
    And lngLocalLongestMatch > 0 _
    And (lngMatchAt1 > 1 Or lngMatchAt2 > 1) _
    , "*", "")
End If

RetMatch = RetMatch & Mid$(FirstString, lngMatchAt1 + 1, lngLocalLongestMatch)

lngLongestMatch = lngLongestMatch _
+ Similarity_sub(lngMatchAt1 + lngLocalLongestMatch, end1, _
lngMatchAt2 + lngLocalLongestMatch, end2, _
b1, b2, _
FirstString, _
strRetMatch2, _
min_match, _
recur_level + 1)

If strRetMatch2 <> "" Then
    RetMatch = RetMatch & "*" & strRetMatch2
Else
    RetMatch = RetMatch & IIf(recur_level = 0 _
    And lngLocalLongestMatch > 0 _
    And ((lngMatchAt1 + lngLocalLongestMatch < end1) _
    Or (lngMatchAt2 + lngLocalLongestMatch < end2)) _
    , "*", "")
End If

Similarity_sub = lngLongestMatch

End Function

这段代码扫描a列和b列，如果发现两列有任何相似之处，就会以黄色显示。你可以使用颜色过滤器来获得最终值。我没有把这部分加入代码中。

Sub item_difference()

Range("A1").Select

last_row_all = Range("A65536").End(xlUp).Row
last_row_new = Range("B65536").End(xlUp).Row

Range("A1:B" & last_row_new).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 65535
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With

For i = 1 To last_row_new
For j = 1 To last_row_all

If Range("A" & i).Value = Range("A" & j).Value Then

Range("A" & i & ":B" & i).Select
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorDark1
    .TintAndShade = 0
  .PatternTintAndShade = 0
End With

End If
Next j
Next i
End Sub

虽然我的解决方案不允许识别非常不同的字符串，但它对于部分匹配（子串匹配）很有用，例如 “这是一个字符串 "和 "一个字符串 "将导致 "匹配"。

只需在要查找的字符串前后加上”/*“即可

通常的公式:

• vlookup(A1,B1:B10,1,0)
• cerca.vert(A1;B1:B10;1;0)

变成

• vlookup(”*“ & A1 & ”*“,B1:B10;1,0)
• cerca. vert(”*“ & A1 & ”*“;B1:B10;1;0)

”&“是concatenate()的 "简版"。

你可以使用相似度函数(pwrSIMILARITY)来比较字符串，并得到两个字符串的匹配百分比。你可以让它区分大小写或不区分大小写。你需要决定什么百分比的匹配度是 “足够接近 "的。

在 http://officepowerups.com/help-support/excel-function-reference/excel-text-analyzer/pwrsimilarity/ 有一个参考页面。

但它在比较A列和B列的文本时效果很好。