Levenshtein.vba

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

Private Function Levenshtein(S1 As String, S2 As String)

Dim i As Integer, j As Integer
Dim l1 As Integer, l2 As Integer
Dim d() As Integer
Dim min1 As Integer, min2 As Integer

l1 = Len(S1)
l2 = Len(S2)
ReDim d(l1, l2)
For i = 0 To l1
    d(i, 0) = i
Next
For j = 0 To l2
    d(0, j) = j
Next
For i = 1 To l1
    For j = 1 To l2
        If Mid(S1, i, 1) = Mid(S2, j, 1) Then
            d(i, j) = d(i - 1, j - 1)
        Else
            min1 = d(i - 1, j) + 1
            min2 = d(i, j - 1) + 1
            If min2 < min1 Then
                min1 = min2
            End If
            min2 = d(i - 1, j - 1) + 1
            If min2 < min1 Then
                min1 = min2
            End If
            d(i, j) = min1
        End If
    Next
Next
Levenshtein = d(l1, l2)
End Function


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

Const treshold = 1
For Each S2 In wordrange
    oldRes = newRes
    newRes = Levenshtein(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
    LevenshteinCompare = newRes & " - [" & newS2row & "]  " & newS2
Else
    LevenshteinCompare = ""
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).