Find the word which I closest to the particular string?

Question

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

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 ?

Answer 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

Answer 2

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

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