VBA字符串模糊匹配 Version 2 （支持中文)

Mengkelyu

大家在工作过程中，可能会遇到需要模糊匹配字符串的情况；
比如需要把简写疾病名称和一些已知疾病的名称进行匹配。

珂珂帮大家整理了一个匹配函数matchName，可以直接复制到工作表的模块中使用哦。

用法：第一个参数是匹配对象，第二个是匹配列表

结果：

代码如下，匹配度计算参考这个博客

Public Function matchName(Target As String, TargetRange As Range) As String

On Error Resume Next

Dim tr As Variant, i As Integer, Temp_value As Double, Temp_result As String, final_value As Double

tr = TargetRange.Value

Temp_result = tr(1, 1)

For i = 1 To UBound(tr, 1)

    Temp_value = sim(tr(i, 1), Target)
    If Temp_value > final_value Then
        final_value = Temp_value
        Temp_result = tr(i, 1)
    End If

Next i

matchName = Temp_result

End Function

Private Function min(one As Integer, two As Integer, three As Integer)

min = one

If (two < min) Then
    min = two
End If

If (three < min) Then
    min = three
End If

End Function

Private Function ld(str1 As String, str2 As String)
Dim N, m, i, j As Integer
Dim ch1, ch2 As String

N = Len(str1)
m = Len(str2)

Dim temp As Integer

If (N = 0) Then
    ld = m
End If

If (m = 0) Then
    ld = N
End If

Dim d As Variant
ReDim d(N + 1, m + 1) As Variant
    For i = 0 To N
        d(i, 0) = i
    Next i
    For j = 0 To m
        d(0, j) = j
    Next j
    For i = 1 To N
        ch1 = Mid(str1, i, 1)
        For j = 1 To m
            ch2 = Mid(str2, j, 1)
            If (ch1 = ch2) Then
            temp = 0
            Else
                temp = 1
            End If
            d(i, j) = min(d(i - 1, j) + 1, d(i, j - 1) + 1, d(i - 1, j - 1) + temp)
        Next j
    Next i
    ld = d(N, m)
End Function

Public Function sim(ByVal str1 As String, ByVal str2 As String)
    Dim ldint As Integer
    ldint = ld(str1, str2)
    Dim strlen As Integer
    If (Len(str1) >= Len(str2)) Then
        strlen = Len(str1)
    Else
        strlen = Len(str2)
    End If
    If strlen = 0 Then sim = 0 Else sim = 1 - ldint / strlen
End Function