Levenshtein3.vba

'Source: http://stackoverflow.com/a/12494656/935614

Private Function Levenshtein3(ByVal string1 As String, ByVal string2 As String) As Long

Dim i As Long, j As Long
Dim string1_length As Long, string2_length As Long
Dim distance(0 To 60, 0 To 50) As Long
Dim smStr1(1 To 60) As Long, smStr2(1 To 50) As Long
Dim min1 As Long, min2 As Long, min3 As Long
Dim minmin As Long, MaxL As Long

string1_length = Len(string1):  string2_length = Len(string2)

distance(0, 0) = 0
For i = 1 To string1_length:    distance(i, 0) = i: smStr1(i) = Asc(LCase(Mid$(string1, i, 1))): Next
For j = 1 To string2_length:    distance(0, j) = j: smStr2(j) = Asc(LCase(Mid$(string2, j, 1))): Next
For i = 1 To string1_length
    For j = 1 To string2_length
        If smStr1(i) = smStr2(j) Then
            distance(i, j) = distance(i - 1, j - 1)
        Else
            min1 = distance(i - 1, j) + 1
            min2 = distance(i, j - 1) + 1
            min3 = distance(i - 1, j - 1) + 1
            If min2 < min1 Then
                If min2 < min3 Then minmin = min2 Else minmin = min3
            Else
                If min1 < min3 Then minmin = min1 Else minmin = min3
            End If
            distance(i, j) = minmin
        End If
    Next
Next

MaxL = string1_length: If string2_length > MaxL Then MaxL = string2_length
Levenshtein3 = distance(string1_length, string2_length)

End Function


Public Function LevenshteinCompare3(S1 As Range, wordrange As Range)

Const treshold = 1
For Each S2 In wordrange
    oldRes = newRes
    newRes = Levenshtein3(S1.Value, S2.Value)
    If oldRes < newRes And oldRes <> "" Or S1.Address = S2.Address Then
        newRes = oldRes
        newS2 = oldS2
        newS2row = oldS2row
    Else
        oldS2 = S2
        oldS2row = S2.Address(0, 0)
    End If
Next

If newRes <= treshold Then
    LevenshteinCompare3 = newRes & " - [" & newS2row & "]  " & newS2
Else
    LevenshteinCompare3 = ""
End If
End Function

Thanks for the example. I arrived here from SuperUser. Just a couple of things:

• There is a small bug that won't allow matching the last element in wordrange. You can check it in the original sample workbook by deleting the "i" in A11. It's easy to fix: just move newS2 = oldS2 out of the If ... End If, just before the Next.
• Also, to avoid looping through a million empty cells when wordrange is something like "A:A", just change the For Each line to For Each S2 In Application.Intersect(wordrange, wordrange.Parent.UsedRange).