Vba 找到最接近特定字符串的单词？

我们做用户对账报告，因为我们需要找到为特定用户分配的电子邮件id

对于ex

客户报告用户名可能如下所示

Sathish K
Sathya A

但在我们的合并报告中，实际用户名将如下所示

Sathish Kothandam
Sathya Arjun

所以我创建了一个宏

Sub test
Dim t as string 
t= “Sathish K”
msgbox(getemailId(t))
End sub

    Dim rng As Range

Function getemailId(Byval findString As String)
    With ActiveWorkbook.Sheets("CONSOLIDATED").Range("B:B")
        Set rng = .find(What:=findString, LookIn:=xlValues)
        If Not rng Is Nothing Then
‘ B – Column contains username C – Email id of the user
            getemailId = rng.offset(0,1).value
        Else
            find1 = 0
        End If
    End With
End Function

我的宏在上述场景中工作得非常好，但有时我可能会收到如下用户名

Satish Kothandam
Sathiya Arjun

但这次它返回0。无论如何，有什么方法可以实现我的目标吗？

---

希望我解释得很好？

请查看下面的示例代码

Sub test()

Dim str1 As String, str2 As String
Dim str1c As String, str2c As String

str1 = "Sathish"
str2 = "Satish"

str1c = SOUNDEX(str1)
str2c = SOUNDEX(str2)

MsgBox str1c = str2c

End Sub

函数SOUNDEX（姓氏为String）为String
由Richard J.Yanco开发
'此函数遵循在中给出的Soundex规则
' http://home.utah-inter.net/kinsearch/Soundex.html
Dim结果作为字符串，c作为字符串*1
作为整数的Dim位置
姓氏=UCase（姓氏）
'第一个字符必须是字母
如果Asc（左（姓1））<65或Asc（左（姓1））>90，则
SOUNDEX=“”
退出功能
其他的
圣徒被改为圣徒
如果左（姓氏3）=“ST.”则
姓氏=“圣人”和米德（姓氏，4）
如果结束
'转换为Soundex：将字母转换为相应的数字，
'A，E，I，O，U，Y（“斜杠字母”）到斜杠
'H、W和其他所有内容都是零长度字符串
结果=左（姓1）
位置=2至Len（姓氏）
结果=结果和类别（中间（姓氏、位置、1））
下一个位置
“删除双字母
位置=2
位置4例
SOUNDEX=左侧（结果，4）
结束选择
如果结束
端函数
私有函数类别（c）为字符串
'返回字母的Soundex代码
选择Case True
案例c类似于“[AEIOUY]”
类别=“/”
案例c如“[BPFV]”
类别=“1”
案例c类似于“[CSKGJQXZ]”
类别=“2”
案例c类似于“[DT]”
类别=“3”
案例c=“L”
类别=“4”
案例c类似于“[MN]”
类别=“5”
案例c=“R”
类别=“6”
这包括H和W、空格、标点符号等。
Category=“”
结束选择
端函数

您可以使用levenshtein算法。它计算两个字符串之间的距离

来源维基媒体

Function levenshtein(a As String, b As String) As Integer

    Dim i As Integer
    Dim j As Integer
    Dim cost As Integer
    Dim d() As Integer
    Dim min1 As Integer
    Dim min2 As Integer
    Dim min3 As Integer

    If Len(a) = 0 Then
        levenshtein = Len(b)
        Exit Function
    End If

    If Len(b) = 0 Then
        levenshtein = Len(a)
        Exit Function
    End If

    ReDim d(Len(a), Len(b))

    For i = 0 To Len(a)
        d(i, 0) = i
    Next

    For j = 0 To Len(b)
        d(0, j) = j
    Next

    For i = 1 To Len(a)
        For j = 1 To Len(b)
            If Mid(a, i, 1) = Mid(b, j, 1) Then
                cost = 0
            Else
                cost = 1
            End If

            ' Since Min() function is not a part of VBA, we'll "emulate" it below
            min1 = (d(i - 1, j) + 1)
            min2 = (d(i, j - 1) + 1)
            min3 = (d(i - 1, j - 1) + cost)

'            If min1 <= min2 And min1 <= min3 Then
'                d(i, j) = min1
'            ElseIf min2 <= min1 And min2 <= min3 Then
'                d(i, j) = min2
'            Else
'                d(i, j) = min3
'            End If
'            In Excel we can use Min() function that is included
'            as a method of WorksheetFunction object
            d(i, j) = Application.WorksheetFunction.Min(min1, min2, min3)
        Next
    Next
    levenshtein = d(Len(a), Len(b))

End Function

函数levenshtein（a作为字符串，b作为字符串）作为整数
作为整数的Dim i
作为整数的Dim j
将成本调整为整数
Dim d（）作为整数
Dim min1作为整数
Dim min2作为整数
Dim min3作为整数
如果Len（a）=0，则
levenshtein=Len（b）
退出功能
如果结束
如果Len（b）=0，则
levenshtein=Len（a）
退出功能
如果结束
雷迪姆d（第（一）组、第（二）组）
对于i=0到Len（a）
d（i，0）=i
下一个
对于j=0到Len（b）
d（0，j）=j
下一个
对于i=1到Len（a）
对于j=1到Len（b）
如果Mid（a，i，1）=Mid（b，j，1），那么
成本=0
其他的
成本=1
如果结束
'由于Min（）函数不是VBA的一部分，我们将在下面“模拟”它
min1=（d（i-1，j）+1）
min2=（d（i，j-1）+1）
min3=（d（i-1，j-1）+成本）
'如果min1，如果可以将数据放入ms access表，则可以使用SOUNDEX。看看这个excel Soundex。嗨，桑托什。谢谢你的建议。但是excel soundex的链接只适用于几个词。不是所有的。。我已从该网站下载了excel工作簿示例并进行了检查？我做了测试，它对我有效。你能给我举一个例子吗，它不起作用。就像我在Sathish Satish上面的例子，sathya satyaThanks代表这个santosh。。这就是我想要的。抱歉，最初误解了函数：）
Function levenshtein(a As String, b As String) As Integer

    Dim i As Integer
    Dim j As Integer
    Dim cost As Integer
    Dim d() As Integer
    Dim min1 As Integer
    Dim min2 As Integer
    Dim min3 As Integer

    If Len(a) = 0 Then
        levenshtein = Len(b)
        Exit Function
    End If

    If Len(b) = 0 Then
        levenshtein = Len(a)
        Exit Function
    End If

    ReDim d(Len(a), Len(b))

    For i = 0 To Len(a)
        d(i, 0) = i
    Next

    For j = 0 To Len(b)
        d(0, j) = j
    Next

    For i = 1 To Len(a)
        For j = 1 To Len(b)
            If Mid(a, i, 1) = Mid(b, j, 1) Then
                cost = 0
            Else
                cost = 1
            End If

            ' Since Min() function is not a part of VBA, we'll "emulate" it below
            min1 = (d(i - 1, j) + 1)
            min2 = (d(i, j - 1) + 1)
            min3 = (d(i - 1, j - 1) + cost)

'            If min1 <= min2 And min1 <= min3 Then
'                d(i, j) = min1
'            ElseIf min2 <= min1 And min2 <= min3 Then
'                d(i, j) = min2
'            Else
'                d(i, j) = min3
'            End If
'            In Excel we can use Min() function that is included
'            as a method of WorksheetFunction object
            d(i, j) = Application.WorksheetFunction.Min(min1, min2, min3)
        Next
    Next
    levenshtein = d(Len(a), Len(b))

End Function