Skip to content

Instantly share code, notes, and snippets.

# /Levenshtein.vbaSecret Created Nov 2, 2013

 '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

### atnbueno commented Feb 15, 2015

 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)`.
to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.