Simil for VBA (code)

[Guus2005]

In the sample databases you'll find my contribution with the same name. If that contribution is approved i'll put a link here.

Simil for VBA
In the table (see sample database) the word "Pennsylvania" is matched with the word "Pencilvaneya" which is a 67% match. Pen(length 3), lvan(length 4) and a(length 1) appears in both strings. (3+4+1)*2/24 (total length)

The Simil function is case sensitive but if you convert both strings to lowercase you can circumvent that. You can also change Option Compare Binary into Option Compare Database in the VBA code.

Below the code since the sample database is in the 2010 format.

Option Compare Binary
Option Explicit

Public Function Simil(strTxt1 As String, strTxt2 As String) As Double
'Determine match percentage between two strings. between 0 (no match) en 1 (identical)

    Dim intTot   As Integer
    Dim strMatch As String
    
    intTot = Len(strTxt1 & strTxt2) 'len(strtxt1) + len(strtxt2) 'Which is faster?
    
    strMatch = GetBiggest(strTxt1, strTxt2)
    
    Simil = CDbl(Len(strMatch) * 2) / CDbl(intTot)

End Function

Public Function GetBiggest(strTxt1 As String, strTxt2 As String) As String
'Returnvalue is all matching strings
'?GetBiggest("Pennsylvania","Pencilvaneya")
'lvanPena

    Dim intLang    As Integer
    Dim intKort    As Integer
    Dim intPos     As Integer
    Dim intX       As Integer
    Dim strLangste As String
    Dim strSearch  As String
    Dim strLang    As String
    Dim strKort    As String
    Dim strTotal1 As String
    Dim strTotal2 As String
    
    intKort = Len(strTxt1)
    intLang = Len(strTxt2)
    
    If intLang > intKort Then
        strLang = strTxt2
        strKort = strTxt1
    ElseIf intKort = 0 Or intLang = 0 Then
        Exit Function
    Else
        strLang = strTxt1
        strKort = strTxt2
        intX = intKort
        intKort = intLang
        intLang = intX
    End If
        
    For intPos = 1 To intKort 'Compare string based on the shortest.
        intX = 0
        Do
            intX = intX + 1
            strSearch = Mid$(strKort, intPos, intX) 'Determine part of string to search for
            If Len(strSearch) <> intX Then
                Exit Do 'end of string
            End If
        Loop While InStr(1, strLang, strSearch) > 0 'Part of string found in other string, increase size of partstring and try again.
        intX = intX - 1
        If intX > Len(strLangste) Then 'Longest substring found
            strLangste = Mid$(strKort, intPos, intX)
        End If
        If intX = 0 Then intX = 1
        intPos = intPos + intX - 1
    Next intPos

    If Len(strLangste) = 0 Then
        GetBiggest = "" 'No matching substring found
    Else 'Substring match found.
        'Split substring in left and right part.
        strTotal1 = Replace(strTxt1, strLangste, "|")
        strTotal2 = Replace(strTxt2, strLangste, "|")
            
        'Recursive part: Try again and paste result to returnvalue.
        GetBiggest = strLangste & _
                        GetBiggest(CStr(Split(strTotal1, "|")(0)), CStr(Split(strTotal2, "|")(0))) & _
                        GetBiggest(CStr(Split(strTotal1, "|")(1)), CStr(Split(strTotal2, "|")(1)))
    End If
    
End Function

Share & Enjoy!

 

[GtAntoine]

AWESOME !!!
Works perfectly with VBA in Excel 2010.
I specially register to say thanks. You saved me one day of development and a crooked solution.

 

[Guus2005]

Glad to be of any help.

Share & Enjoy!