I pulled this out of my code bucket and dusted it off earlier today in response to a post over on SO that made me cringe. This was originally written to highlight changes in Excel cells in real time via
Worksheet_Change, so it is designed with an eye toward raw speed to avoid blocking the UI. Benchmarks on current hardware are running around 3 seconds to compare 2 1kb strings.
I cleaned it up a bit to modernize the coding style, but I'm mainly looking for input on the algorithm used and suggestions for making the code a bit more understandable for somebody who isn't familiar with it.
It basically works on byte arrays and tracks the current working position in each array with a set of index pointers for the "start" and "end" of each substring that it's working with. The algorithm is similar to a binary search. The entry point function finds the longest matching substring in the two byte arrays, excludes it, logs all the differences to the output, and then recursively calls itself on the slices of the arrays to the right and left of the match:
'Returns a comma delimited string containing the positions of differences in the passed byte arrays. Recursive. 'Arrays are not modified, index parameters specify where the pointers are in the arrays on each subsequent call. Private Function FindDifferences(ByRef first() As Byte, ByRef other() As Byte, Optional ByVal firstStartIndex As Long = -1, _ Optional ByVal firstEndIndex As Long, Optional ByVal otherStartIndex As Long, _ Optional ByVal otherEndIndex As Long) As String If firstStartIndex = -1 Then 'Find matching substrings and set index markers. SkipSubstringMatches first, other, firstStartIndex, firstEndIndex, otherStartIndex, otherEndIndex If firstEndIndex = -1 And otherEndIndex > 0 Then 'All matches in first. Exit Function ElseIf otherEndIndex = -1 And firstEndIndex > 0 Then 'All matches in other. FindDifferences = FormatIndexSpanForOutput(firstStartIndex, firstEndIndex) Exit Function ElseIf firstEndIndex = -1 And otherEndIndex = -1 Then 'Identical input. Exit Function End If End If Dim matchLength As Long Dim firstMatch As Long Dim otherMatch As Long FindNextMatch first, other, firstStartIndex, firstEndIndex, otherStartIndex, otherEndIndex, firstMatch, otherMatch, matchLength Dim differences As String Dim returnValue As String 'Test to see if there are unmatched chars. If matchLength <> 0 Then differences = FindDifferences(first, other, firstStartIndex, firstMatch - 1, otherStartIndex, otherMatch - 1) If Len(differences) <> 0 Then returnValue = returnValue & "," & differences differences = FindDifferences(first, other, firstMatch + matchLength, firstEndIndex, otherMatch + matchLength, otherEndIndex) If Len(differences) <> 0 Then returnValue = returnValue & "," & differences Else returnValue = returnValue & "," & FormatIndexSpanForOutput(firstStartIndex, firstEndIndex) End If If Right$(returnValue, 1) = "," Then returnValue = Left$(returnValue, Len(returnValue) - 1) End If If Left$(returnValue, 1) = "," Then returnValue = Right$(returnValue, Len(returnValue) - 1) End If FindDifferences = returnValue End Function
There are a couple helper functions for managing the array indexes - the first skips matching substrings in the 2 arrays:
'Sets ByRef index parameters to the position of the first mismatched byte from both the start and end. Arrays are not modified. Private Sub SkipSubstringMatches(ByRef first() As Byte, ByRef other() As Byte, ByRef firstStartIndex As Long, _ ByRef firstEndIndex As Long, ByRef otherStartIndex As Long, ByRef otherEndIndex As Long) Dim topFirst As Long Dim topOther As Long Dim baseFirst As Long topFirst = UBound(first) topOther = UBound(other) baseFirst = LBound(first) Dim lower As Long If topFirst >= topOther Then lower = topOther Else lower = topFirst End If Dim index As Long Do Until index > lower If first(index) <> other(index) Then Exit Do End If index = index + 1 Loop firstStartIndex = index otherStartIndex = index '-1 indicates all matches. If index > topFirst Then firstEndIndex = -1 otherEndIndex = topOther ElseIf index > topOther Then otherEndIndex = -1 firstEndIndex = topFirst End If If firstEndIndex = -1 Or otherEndIndex = -1 Then Exit Sub Else Do Until first(topFirst) <> other(topOther) topFirst = topFirst - 1 topOther = topOther - 1 If topFirst < baseFirst Or topOther < baseFirst Then Exit Do End If Loop firstEndIndex = topFirst otherEndIndex = topOther End If End Sub
...and a procedure that seeks the next match (finds the start and ending indexes of the mismatch):
'Advance indexes until the next matches are found. Private Sub FindNextMatch(ByRef first() As Byte, ByRef other() As Byte, ByRef firstStartIndex As Long, _ ByRef firstEndIndex As Long, ByRef otherStartIndex As Long, ByRef otherEndIndex As Long, _ ByRef matchPositionFirst As Long, ByRef matchPositionOther As Long, ByRef matchLength As Long) Dim tempIndex As Long Dim result As Long Dim firstIndex As Long Dim otherIndex As Long For otherIndex = otherStartIndex To otherEndIndex firstIndex = firstStartIndex Do Until firstIndex >= firstEndIndex 'Seek forward in first until there is a match. Do Until other(otherIndex) = first(firstIndex) firstIndex = firstIndex + 1 If firstIndex = firstEndIndex Then Exit Do End If Loop 'Concurrently seek forward in both until a mismatch is found. tempIndex = otherIndex Do Until other(tempIndex) <> first(firstIndex) tempIndex = tempIndex + 1 firstIndex = firstIndex + 1 If firstIndex > firstEndIndex Then Exit Do End If If tempIndex > otherEndIndex Then Exit Do End If Loop 'Calculate match indexes and length. result = tempIndex - otherIndex If result > matchLength Then matchLength = result matchPositionOther = otherIndex matchPositionFirst = firstIndex - matchLength End If If matchLength > firstEndIndex - firstIndex Then Exit Do End If Loop If matchLength + otherIndex > otherEndIndex Then 'No possible matches left. Exit For End If Next End Sub
Finally, there's a helper function that formats the output. This could be pretty much anything - in this case it's a comma delimited string of 1 based character indexes (that was the convenient output for the original calling code):
'Returns a comma delimited string of indexes between starting and ending, rebases to 1 base. Private Function FormatIndexSpanForOutput(ByVal starting As Long, ByVal ending As Long) As String Dim returnValue As String If starting = ending Then returnValue = CStr(ending + 1) Else Dim index As Long For index = starting To ending - 1 returnValue = returnValue & CStr(index + 1) & "," Next index If starting < ending Then returnValue = returnValue & CStr(ending + 1) End If End If FormatIndexSpanForOutput = returnValue End Function
...and a simple wrapper for calling it with string input instead of array input - note that this isn't unicode aware.
'Just a wrapper for passing strings instead of byte arrays. Public Function StringDiffs(ByVal first As String, ByVal other As String) As String Dim firstChars() As Byte Dim otherChars() As Byte firstChars = StrConv(first, vbFromUnicode) otherChars = StrConv(other, vbFromUnicode) StringDiffs = FindDifferences(firstChars, otherChars) End Function
For convenience (bad side-scrolling here), the full module is also on Pastebin.
Public Sub Demo() Dim first As String Dim other As String first = "This is a test string." other = "This was a test thing." Debug.Print StringDiffs(first, other) & " in string 1 were deleted." Debug.Print StringDiffs(other, first) & " in string 2 were inserted." End Sub
6,16,18 in string 1 were deleted. 6,7,18 in string 2 were inserted.