Create a gist now

Instantly share code, notes, and snippets.

anonymous /Levenshtein.vba Secret
Created Nov 2, 2013

What would you like to do?
'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).
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment