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

We do user reconciliation report, in that we need to find the email id assigned for the particular user.

我们会执行用户对帐报告,因为我们需要找到为特定用户分配的电子邮件ID。

For ex

Customer report user name may look like this

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

Sathish K
Sathya A

But in our consolidation report actual user name will be look like this

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

Sathish Kothandam
Sathya Arjun

So I have created a macro

所以我创建了一个宏

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

My macro works perfectly above scenario ,but sometime I may receive user name like below

我的宏在场景上工作得很好,但有时我可能会收到如下所示的用户名

Satish Kothandam
Sathiya Arjun

But this times It returns 0 . Is there any way to achieve my goal in anyway ? Hope I explained well ?

但这次它返回0。无论如何都有办法实现我的目标吗?希望我解释得好吗?

2 个解决方案

#1

Please have look at below sample code.

请看下面的示例代码。

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

Function SOUNDEX(Surname As String) As String
' Developed by Richard J. Yanco
' This function follows the Soundex rules given at
' http://home.utah-inter.net/kinsearch/Soundex.html

    Dim Result As String, c As String * 1
    Dim Location As Integer

    Surname = UCase(Surname)

'   First character must be a letter
    If Asc(Left(Surname, 1)) < 65 Or Asc(Left(Surname, 1)) > 90 Then
        SOUNDEX = ""
        Exit Function
    Else
'       St. is converted to Saint
        If Left(Surname, 3) = "ST." Then
            Surname = "SAINT" & Mid(Surname, 4)
        End If

'       Convert to Soundex: letters to their appropriate digit,
'                     A,E,I,O,U,Y ("slash letters") to slashes
'                     H,W, and everything else to zero-length string

        Result = Left(Surname, 1)
        For Location = 2 To Len(Surname)
            Result = Result & Category(Mid(Surname, Location, 1))
        Next Location

'       Remove double letters
        Location = 2
        Do While Location < Len(Result)
            If Mid(Result, Location, 1) = Mid(Result, Location + 1, 1) Then
                Result = Left(Result, Location) & Mid(Result, Location + 2)
            Else
                Location = Location + 1
            End If
        Loop

'       If category of 1st letter equals 2nd character, remove 2nd character
        If Category(Left(Result, 1)) = Mid(Result, 2, 1) Then
            Result = Left(Result, 1) & Mid(Result, 3)
        End If

'       Remove slashes
        For Location = 2 To Len(Result)
            If Mid(Result, Location, 1) = "/" Then
                Result = Left(Result, Location - 1) & Mid(Result, Location + 1)
            End If
        Next

'       Trim or pad with zeroes as necessary
        Select Case Len(Result)
            Case 4
                SOUNDEX = Result
            Case Is < 4
                SOUNDEX = Result & String(4 - Len(Result), "0")
            Case Is > 4
                SOUNDEX = Left(Result, 4)
        End Select
    End If
End Function

Private Function Category(c) As String
'   Returns a Soundex code for a letter
    Select Case True
        Case c Like "[AEIOUY]"
            Category = "/"
        Case c Like "[BPFV]"
            Category = "1"
        Case c Like "[CSKGJQXZ]"
            Category = "2"
        Case c Like "[DT]"
            Category = "3"
        Case c = "L"
            Category = "4"
        Case c Like "[MN]"
            Category = "5"
        Case c = "R"
            Category = "6"
        Case Else 'This includes H and W, spaces, punctuation, etc.
            Category = ""
    End Select
End Function

#2

You can use the levenshtein algorythm. It calculates the distance between two strings.

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

Source Wikimedia

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