VBA routine to perform Text Diff

[acatalux]

Hello everybody, I am new to the forum but I have been an avid reader of your discussions.
As always stated by common forum rules of behavior, don't start a new post if you can already find the answer in other's discussions.

Well, this is the first time I need to start a new post, because it seems the answer is nowhere on the internet.

I am looking to implement the "Compare Documents" function (available in Word 2010) in Excel 2010 through VBA programming between different text contained in two cells.
In Word this function works quite well (not perfectly), but it highlights in different ways which part has been deleted and which one has been added between an "original" document and a "revised" one.
For the nature of my job, I need to do this on a daily basis and I used to output text from Excel to Word, then compare the two text, and then copy it back to Excel.

Here comes the problem: since in Word the text is formatted (and what I'm looking for is formatted/highlighted text as output), I can't just paste it in Excel as it is: any editing, merging, splitting done on the pasted text (that eventually I need to do) makes the formatting disappear (above all with VBA functions, that can only output data and can't format it).

So, browsing the internet I found an implementation of the LCS (Longest Common Subsequence) algorithm written for VBA: you can find it here (for what I see a very neat job by Travis Hydzik). I looked at the strings function only, even though the author provides functions for arrays as well.

I started to tailor his script to my needs, and at first I claimed victory. But as I applied the code to other situations, I couldn't get the right answer.
Anyway, the behaviour that I expect is exactly the same that is provided by the "Compare Documents" in Word 2010.

In other words: given two cells containing different text, I would like to be able to fill a third cell with text formatted accordingly to the TextDiff output between the two original cell.

E.g.:
INPUT:
Cells(1,1).Value2 = "my name is Andrea and I like jogging" (original)
Cells(1,2).Value2 = "my name is Giovanni and I like running" (revised)

OUTPUT:
Cells(1,3) wll contain: "my name is <strike>Andrea</strike>Giovanni and I like <strike>jogging</strike>running"

Obviously, since UDF doesn't allow formatting of cells, I would need to adjust the main Sub for each pair of document I have to revise, but that won't be the problem: what I need is the engine. It's been two years and a half that I do advanced VBA programming at work but it looks like I can't grasp the rationale behind the LCS algorithm.

Any suggestion, hint, link or other resource is more than welcome.
I hope you could help me find a solution to this (considering it is quite useful anyhow).

Best regards,
Andrea.

P.S.: I don't post any code since I used the code "as is" developed by the guy as the engine/core and I edited the example Sub to my needs, converting "+", "-" and "=" to text formatting using the .Characters object.

 

[achar]

Firstly, great post! Invaluable pieces of code.

Mike, sir your code worked wonders for me. I tried tweaking it by having a Userform's "Userform1.Textbox1" and "Userform1.Textbox2" as inputs instead of cells A1 and B1 discussed above.
The output (compared result), I try displaying in Userform1.Textbox3 of the same userform.
But unfortunately, Im a novice when it comes to VBA. I do not know how to change the code to make the result appear in Userform1.Textbox3 using the With..End With like how you have. I understand that the arguments of the function call:

Call CompareAndDisplay(aStr, bStr, Range("S1"))

Need to change along with the

CompareAndDisplay(strOne As String, strTwo As String, outCell As Range, Optional Delimiter As String = " ")
[I][COLOR=#574123].
.
.
With outCell.Cells(1, 1)[/COLOR]
[COLOR=#574123].Clear[/COLOR]
[COLOR=#574123].Value = strResult[/COLOR]
[COLOR=#574123]For i = LBound(olStart) To UBound(olStart)[/COLOR]
[COLOR=#574123]If olStart(i) <> 0 Then[/COLOR]

[COLOR=#574123]With .Characters(olStart(i), olLength(i)).Font[/COLOR]
[COLOR=#574123].ColorIndex = 3[/COLOR]
[COLOR=#574123].StrikeThrough = True[/COLOR]
[COLOR=#574123]End With[/COLOR][/I]

I tried and all I managed was Copying the result stored in C1 into Userform.Textbox3, like:

Userform1.Textbox.Value=Range("C1").Value

The trouble with this is that the userform wont allow for font color/format changes like StrikeThroughs and underlines. So in the end, the result in Userform1.Textbox3 is displayed, but with out any kind of formatting so its impossible to understand and pick out the differences. Could you please help find a way to display the compare result (with differences HIGHLIGHTED) in a Userform.Textbox field?
Thanks in advance!

 

[mikerickson]

No userform controls support rich text.
I only vaguly remember this thread, but you might want two result text boxes. Combined result and then a result with the words in common replaced by ellipsis.

Input1: John went to the candy store
Input2: John Smith went to the store

Output1: John Smith went to the candy store
Output2: .....Smith.............candy......

 

[mikerickson]

A further thought that I had is that instead of green and red, one could use UPPERCASE and lowercase.

 

[achar]

Ok, that sounds good. Will try that out. Thanks for the quick reply!

 

[johnweber]

Must say this is quite the code. I cant believe my luck, to be honest this is exactly what Ive been searching for.
Except the req is a little different as far as the output goes. Is there anyway the output of the

ComparedText(strOne, strTwo, olStart, olLength, nwStart, nwLength)

can be displayed in a word document?

 

[mikerickson]

ComparedText is a function that returns a string, so your question is equivalent to "Given a string can it be put in Word".

This code will get the text into an open Word document, but I'm not experience at this, if there are further questions about that topic, you should start a new thread.

Sub test()
    Dim myWord As Object
    Dim StringToInsert As String
    
    StringToInsert =ComparedText(strOne, strTwo, olStart, olLength, nwStart, nwLength)

    Set myWord = GetObject(, "Word.Application")
    
    myWord.Selection.TypeText Text:=StringToInsert
End Sub

 

[RyDowte]

Dear All,

I am brand new to VBA so please bear with me. These codes are amazing but I am running into a few issues.

string1= Part II Long / Non Producer F2F / Part III BMI / Part III BP / MIB / BCP-Protein / BCP-KF / BCP-Glucose / BCP-Chol / BCP-LF / BCP-HIV / HOS / I\ADL Qs / APS / MVR

string2= Part II Long / Non Producer F2F / Part III BMI / Part III BP / MIB / BCP-Protein / BCP-KF / BCP-Glucose / BCP-Chol / BCP-LF / BCP-HIV / NT-proBNP / PSA / HOS / APS / MVR

I have barely tweaked a couple codes from this thread as follows:
Code 1:

Sub exampleString()
'This is the code i am working on
'This code should be used moving forward


Dim r As Integer
Dim w As Integer
For r = 4 To 12


For w = 4 To 10




Cells(r + 26, w).Clear
   Dim arr() As Long
    
    Dim String1 As String
    Dim String2 As String
    Dim Target As Range
    
    String1 = Cells(r, w)
    String2 = Cells(r + 13, w)
    
    arr = longestCommonSubsequence(String1, String2)
    
    Dim s As String, t As String
    s = backTraceUp(arr, String1, String2, Len(String1), Len(String2))
    t = backTraceLeft(arr, String1, String2, Len(String1), Len(String2))
    Dim a As String, B As String
    a = getDiff(arr, String1, String2, Len(String1), Len(String2))
    
    
    Set Target = ActiveSheet.Cells(r + 26, w)
    
    Dim i As Integer
    For i = 2 To Len(a) Step 2
        Target.Value2 = Target.Value2 & Mid(a, i - 1, 1)
    Next i
    For i = 2 To Len(a) Step 2
        Select Case Mid(a, i, 1)
        Case "-"
            With Target.Characters(i / 2, 1).Font
                .Strikethrough = True
                .Color = RGB(255, 0, 0)
                .Bold = False
            End With
        Case "+"
            With Target.Characters(i / 2, 1).Font
                .ColorIndex = 4
                .Bold = False
                .Underline = xlUnderlineStyleSingle
            End With
        End Select
    Next i
    Dim brr() As Long
    Next w
    Next r
    
End Sub
Public Function longestCommonSubsequence(ByRef String1 As String, ByRef String2 As String) As Long()
    If String1 = vbNullString Or String2 = vbNullString Then
        Exit Function
    End If
 
    Dim num() As Long
    
    'define the array, note rows of zeros get added to front automatically
    ReDim num(Len(String1), Len(String2))
    
    Dim i As Long, j As Long
    
    For i = 1 To Len(String1)
        For j = 1 To Len(String2)
            If Mid$(String1, i, 1) = Mid$(String2, j, 1) Then
                num(i, j) = num(i - 1, j - 1) + 1
            Else
                num(i, j) = max(num(i - 1, j), num(i, j - 1))
            End If
        Next j
    Next i




    longestCommonSubsequence = num
End Function
'back traces c, defaulting in the up direction
Public Function backTraceUp(ByRef C() As Long, ByRef String1 As String, ByRef String2 As String, ByRef i As Long, ByRef j As Long) As String
    If i < 1 Or j < 1 Then
        backTraceUp = vbNullString
    ElseIf Mid$(String1, i, 1) = Mid$(String2, j, 1) Then
        'equal characters, save it and then go up and left
        backTraceUp = backTraceUp(C, String1, String2, i - 1, j - 1) & Mid$(String1, i, 1)
    Else
        'go in the direction of the highest number, defaulting to up
        If (C(i, j - 1) > C(i - 1, j)) Then
            backTraceUp = backTraceUp(C, String1, String2, i, j - 1)
        Else
            backTraceUp = backTraceUp(C, String1, String2, i - 1, j)
        End If
    End If
End Function
'back traces c, defaulting in the left direction
Public Function backTraceLeft(ByRef C() As Long, ByRef String1 As String, ByRef String2 As String, ByRef i As Long, ByRef j As Long) As String
    If i < 1 Or j < 1 Then
        backTraceLeft = vbNullString
    ElseIf Mid$(String1, i, 1) = Mid$(String2, j, 1) Then
        'equal characters, save it and then go up and left
        backTraceLeft = backTraceLeft(C, String1, String2, i - 1, j - 1) & Mid$(String1, i, 1)
    Else
        'go in the direction of the highest number, defaulting to left
        If (C(i, j - 1) >= C(i - 1, j)) Then
            backTraceLeft = backTraceLeft(C, String1, String2, i, j - 1)
        Else
            backTraceLeft = backTraceLeft(C, String1, String2, i - 1, j)
        End If
    End If
End Function
'the following function returns a string with indication to what was deleted or added
'proceding character can be;
' = no change
' - deletion
' + addition
Public Function getDiff(ByRef C() As Long, ByRef stringOld As String, ByRef stringNew As String, ByRef i As Long, ByRef j As Long) As String
    If i > 0 Then
        If j > 0 Then 'both are greater than zero
            'can only do the following comparison when i and j are greater than zero
            If Mid$(stringOld, i, 1) = Mid$(stringNew, j, 1) Then
                getDiff = getDiff(C, stringOld, stringNew, i - 1, j - 1) & Mid$(stringOld, i, 1) & "="
            Else
                If i = 0 Then
                    getDiff = getDiff(C, stringOld, stringNew, i, j - 1) & Mid$(stringNew, j, 1) & "+"
                ElseIf C(i, j - 1) >= C(i - 1, j) Then
                    getDiff = getDiff(C, stringOld, stringNew, i, j - 1) & Mid$(stringNew, j, 1) & "+"
                ElseIf j = 0 Then
                    getDiff = getDiff(C, stringOld, stringNew, i - 1, j) & Mid$(stringOld, i, 1) & "-"
                ElseIf C(i, j - 1) < C(i - 1, j) Then
                    getDiff = getDiff(C, stringOld, stringNew, i - 1, j) & Mid$(stringOld, i, 1) & "-"
                Else
                    getDiff = vbNullString
                End If
            End If
        Else 'i is is greater than zero
                If j = 0 Then
                    getDiff = getDiff(C, stringOld, stringNew, i - 1, j) & Mid$(stringOld, i, 1) & "-"
                ElseIf C(i, j - 1) < C(i - 1, j) Then
                    getDiff = getDiff(C, stringOld, stringNew, i - 1, j) & Mid$(stringOld, i, 1) & "-"
                Else
                    getDiff = vbNullString
                End If
        End If
    Else
        If j > 0 Then 'j is  greater than zero
                If i = 0 Then
                    getDiff = getDiff(C, stringOld, stringNew, i, j - 1) & Mid$(stringNew, j, 1) & "+"
                ElseIf C(i, j - 1) >= C(i - 1, j) Then
                    getDiff = getDiff(C, stringOld, stringNew, i, j - 1) & Mid$(stringNew, j, 1) & "+"
                Else
                    getDiff = vbNullString
                End If
        Else 'none are greater than zero
                getDiff = vbNullString
        End If
    End If
End Function
Public Function max(ByRef a As Long, ByRef B As Long) As Long
    If a >= B Then
        max = a
    Else
        max = B
    End If
End Function

Code 2:

Sub test_UW()
    Dim aStr As String
    Dim bStr As String
    Dim r As Integer
    Dim s As Integer
    For r = 4 To 12
    
    
    For s = 4 To 10
    
    
    aStr = Cells(r, s)
    bStr = Cells(r + 13, s)
    
    Call CompareAndDisplay(aStr, bStr, Cells(r + 26, s))
    
    Next s
    Next r
    
End Sub


Sub CompareAndDisplay(strOne As String, strTwo As String, outCell As Range, Optional Delimiter As String = " ")
    Dim strResult As String
    Dim olStart As Variant, olLength As Variant
    Dim nwStart As Variant, nwLength As Variant
    Dim i As Long
    
    strResult = ComparedText(strOne, strTwo, olStart, olLength, nwStart, nwLength)
    
    With outCell.Cells(1, 1)
        .Clear
        .Value = strResult
        For i = LBound(olStart) To UBound(olStart)
            If olStart(i) <> 0 Then
                
                With .Characters(olStart(i), olLength(i)).Font
                    .ColorIndex = 3
                    .Strikethrough = True
                End With
            End If
        Next i
        For i = LBound(nwStart) To UBound(nwStart)
            If nwStart(i) <> 0 Then
                With .Characters(nwStart(i), nwLength(i)).Font
                    .ColorIndex = 4
                    .Underline = True
                End With
            End If
        Next i
    End With
End Sub




Function ComparedText(aString As String, bString As String, _
                                        Optional ByRef oStart As Variant, Optional oLength As Variant, _
                                        Optional ByRef nStart As Variant, Optional ByRef nLength As Variant, _
                                        Optional Delimiter As String = " ") As String
    Dim aWords As Variant, aWord As String
    Dim bWords As Variant
    Dim outWords() As String
    Dim aPoint As Long, bPoint As Long, outPoint As Long
    Dim matchPoint As Variant, outLength As Long
    Dim High As Long
    Dim oldStart() As Long, oldLength() As Long, oldPoint As Long
    Dim newStart() As Long, newLength() As Long, newPoint As Long
    
    Rem remove double delimiters
        'to be done
        
    aWords = Split(aString, Delimiter)
    bWords = Split(bString, Delimiter)
    High = UBound(aWords)
    ReDim outWords(0 To High + UBound(bWords))
    ReDim oldStart(0 To High + UBound(bWords)): ReDim oldLength(0 To High + UBound(bWords))
    ReDim newStart(0 To High + UBound(bWords)): ReDim newLength(0 To High + UBound(bWords))
    oldPoint = -1: newPoint = -1
    outLength = Len(Delimiter)
    aPoint = 0: bPoint = 0: outPoint = LBound(outWords) - 1
    
    Do
        aWord = aWords(aPoint)
        If LCase(aWord) = LCase(bWords(bPoint)) Then
            Rem is word in common
            outPoint = outPoint + 1
            outWords(outPoint) = aWord
            outLength = outLength + Len(aWord) + Len(Delimiter)
            bWords(bPoint) = vbNullString
            aPoint = aPoint + 1
            bPoint = bPoint + 1
        Else
            Rem word divergence
            matchPoint = Application.Match(aWord, bWords, 0)
            If IsError(matchPoint) Then
                Rem old word is not in new string
                outPoint = outPoint + 1
                outWords(outPoint) = aWord
                
                oldPoint = oldPoint + 1
                oldStart(oldPoint) = outLength: oldLength(oldPoint) = Len(aWord)
                
                outLength = outLength + Len(aWord) + Len(Delimiter)
                aPoint = aPoint + 1
            Else
                Rem old word is in new string, i.e. is a common word
                
                Do Until LCase(bWords(bPoint)) = LCase(aWord)
                    outPoint = outPoint + 1
                    outWords(outPoint) = bWords(bPoint)
                    
                    newPoint = newPoint + 1
                    newStart(newPoint) = outLength: newLength(newPoint) = Len(bWords(bPoint))
        
                    outLength = outLength + Len(outWords(outPoint)) + Len(Delimiter)
                    bWords(bPoint) = vbNullString
                    bPoint = bPoint + 1
                Loop
            End If
        End If
    Loop Until (High < aPoint) Or (UBound(bWords) < bPoint)
    
    Rem last new/different string
    Do Until UBound(bWords) < bPoint
        outPoint = outPoint + 1
        outWords(outPoint) = bWords(bPoint)
        
        newPoint = newPoint + 1
        newStart(newPoint) = outLength: newLength(newPoint) = Len(bWords(bPoint))
        
        outLength = outLength + Len(outWords(outPoint)) + Len(Delimiter)
        bPoint = bPoint + 1
    Loop
    
    Rem final common string
    Do Until High < aPoint
        outPoint = outPoint + 1
        outWords(outPoint) = aWords(aPoint)
        
        oldPoint = oldPoint + 1
        oldStart(oldPoint) = outLength: oldLength(oldPoint) = Len(aWords(aPoint))
        
        outLength = outLength + Len(outWords(outPoint)) + Len(Delimiter)
        aPoint = aPoint + 1
    Loop
    
    ReDim Preserve outWords(0 To outPoint)
    oStart = oldStart: oLength = oldLength
    nStart = newStart: nLength = newLength
    ComparedText = Join(outWords, Delimiter)
End Function

Code 1 yields:
Part II Long / Non Producer F2F / Part III BMI / Part III BP / MIB / BCP-Protein / BCP-KF / BCP-Glucose / BCP-Chol / BCP-LF / BCP-HIV / <strike>HOS</strike>NT-proBNP / <strike>I\</strike>PSA<strike>DL</strike> <strike>Qs</strike>/ HOS / APS / MVR


Code 2 yields:
Part II Long / Non Producer F2F / Part III BMI / Part III BP / MIB / BCP-Protein / BCP-KF / BCP-Glucose / BCP-Chol / BCP-LF / BCP-HIV / NT-proBNP / PSA / HOS / <strike>I\ADL</strike> <strike>Qs</strike> APS / <strike>APS</strike> <strike>/</strike> MVR


I would like to strike through red what has been taken away from string1 and underline green what has been added from string2. So my desired output would be:
Part II Long / Non Producer F2F / Part III BMI / Part III BP / MIB / BCP-Protein / BCP-KF / BCP-Glucose / BCP-Chol / BCP-LF / BCP-HIV / NT-proBNP / PSA / HOS / <strike>I\ADL</strike> <strike>Qs</strike> / APS / MVR



Sometimes these codes work perfectly and other times I run into these issues. Any help would be much appreciated. Thank You!!

 

[DieterG]

I've used acatalux code for some time and it worked quiet well for me but it has some flaws which bothered me at times:
* I'm getting random "error 400" messages as a result of some issues with the clipboard while copying the text from word to excel
* speed is an issue, not just firing up word etc, but also coloring the text of cells containing long strings


So i went back to his original idea of using a VBA implementation of the LCS algorythm he mentioned in his original post. I didn't try to understand the logic behind that code, instead i'd figured how the code processed the strings and what kind of results I get. The code has two implementations of the same problem, one directly processing a string character by character, the other one is processing an array of strings (where each string contains only one character). Both of them produce the ugly result acatalux complained about in post #10.


My idea was to modify the problem a bit and instead of compairing the strings simply character by character it now compaires whole words and non-word characters. It's done by creating a new function to build the array to be processed using RegEx. I've kept it really simple so a word is a string containing only a-z but not umlauts etc. (for the end result that simplification doesn't really matter).

Here is my LCS code (requires a reference to "Microsoft VBScript Regular Expression 5.5" to work). It is used by the module at the end of this post:

Attribute VB_Name = "StringDiff"'needs a reference to "Microsoft VBScript Regular Expressions 5.5" to work
'stripped down and improved version of the module found here: http://thydzik.com/longest-common-subsequence-implemented-in-vba-visual-basic-for-applications/
'
'improvements:
'* words based instead of charakter based
'* words only contain a-z (case ignored)
'* other characters are used to split words
'* words are compared as whole words ignoring the character case
'* non-word characters are compared individually
'* example: "want2win" is considered as 2 words an one non-word character
'
'future improvements:
'* find minor changes in words and mark them like non-word characters




Option Explicit




'resulting array:
'0: common sequences
'1: removed sequences
'2: added sequences
Public Function compare_strings(ByRef string1 As String, ByRef string2 As String) As String()




    Dim a1() As String
    Dim a2() As String
    
    a1 = stringToWordArray(string1)
    a2 = stringToWordArray(string2)
    
    compare_strings = reduce_diff_array(getDiffArr(longestCommonSubsequenceArr(a1, a2), a1, a2, UBound(a1), UBound(a2)))
        
End Function




Public Function get_string_diff(ByRef dif() As String) As String
    Dim outString As String
    Dim i As Long
    
    For i = LBound(dif, 2) To UBound(dif, 2)
        If Len(dif(0, i)) > 0 Then
            outString = outString & dif(0, i)
        End If
        If Len(dif(1, i)) > 0 Then
            outString = outString & "-" & dif(1, i)
        End If
        If Len(dif(2, i)) > 0 Then
            outString = outString & "+" & dif(2, i)
        End If
    Next i
    get_string_diff = outString
End Function




Public Function get_combined_diff_string(ByRef dif() As String) As String
    Dim outString As String
    Dim i As Long
    
    For i = LBound(dif, 2) To UBound(dif, 2)
        If Len(dif(0, i)) > 0 Then
            outString = outString & dif(0, i)
        End If
        If Len(dif(1, i)) > 0 Then
            outString = outString & dif(1, i)
        End If
        If Len(dif(2, i)) > 0 Then
            outString = outString & dif(2, i)
        End If
    Next i
    get_combined_diff_string = outString
End Function




Public Function get_markup_diff_string(ByRef dif() As String) As String()
    Dim outString As String
    Dim i As Long
    
    For i = LBound(dif, 2) To UBound(dif, 2)
        If Len(dif(0, i)) > 0 Then
            outString = outString & num_chars(Len(dif(0, i)), "=")
        End If
        If Len(dif(1, i)) > 0 Then
            outString = outString & num_chars(Len(dif(1, i)), "-")
        End If
        If Len(dif(2, i)) > 0 Then
            outString = outString & num_chars(Len(dif(2, i)), "+")
        End If
    Next i
    get_markup_diff_string = stringToArray(outString)
End Function




Public Function num_chars(length As Long, char As String) As String
    Dim i As Long
    num_chars = ""
    For i = 1 To length
        num_chars = num_chars + char
    Next i
End Function








Public Function max_long(ByRef a As Long, ByRef b As Long) As Long
    If a >= b Then
        max_long = a
    Else
        max_long = b
    End If
End Function




'note, arrays must be single dimension
Public Function longestCommonSubsequenceArr(ByRef array1() As String, ByRef array2() As String) As Long()
    On Error Resume Next
    If UBound(array1, 2) > 0 Or UBound(array2, 2) > 0 Then 'multidimensional arrays
        If Error = vbNullString Then
            Exit Function
        End If
    End If
    
    If UBound(array1) < 0 Or UBound(array2) < 0 Then 'check if arrays are bounded
        If Error <> vbNullString Then
            Exit Function
        End If
    End If




    Dim num() As Long
    
    'define the array, note rows of zeros get added to front automatically
    ReDim num(UBound(array1) + 1, UBound(array2) + 1)
    
    Dim i As Long, j As Long
    
    'note, arrays must always start at indice zero.
    For i = 0 To UBound(array1)
        For j = 0 To UBound(array2)
'            If array1(i) = array2(j) Then
            If StrComp(array1(i), array2(j)) = 0 Then
                num(i + 1, j + 1) = num(i, j) + 1
            Else
                num(i + 1, j + 1) = max_long(num(i, j + 1), num(i + 1, j))
            End If
        Next j
    Next i




    longestCommonSubsequenceArr = num
End Function




'not uses but kept for future improvements
Public Function stringToArray(ByRef str As String) As String()
    Dim i As Long
    Dim arr() As String
    ReDim arr(Len(str) - 1)
    For i = 1 To Len(str)
        arr(i - 1) = Mid$(str, i, 1)
    Next i
    stringToArray = arr
End Function




Public Function stringToWordArray(ByRef str As String) As String()
    Dim regEx   ' Create variable.
    Dim aMatches, aMatch
    Dim a() As String
    Dim i As Long
    
    Set regEx = New RegExp   ' Create a regular expression.
    regEx.Pattern = "[^a-z]" 'lower case only
    regEx.Pattern = "([a-z]+)|([^a-z])" 'lower case only here, ignoring case anyway
    regEx.Global = True
    regEx.IgnoreCase = True
    
    Set aMatches = regEx.Execute(str)
    
    ReDim a(aMatches.Count - 1)
    For i = 0 To UBound(a)
        a(i) = aMatches.Item(i)
    Next i
    
    stringToWordArray = a
    
End Function




'returns a 2xn array, where
'indice 0 are equal
'indice 1 are deletions
'indice 2 are additions
Public Function getDiffArr(ByRef c() As Long, ByRef arrayOld() As String, ByRef arrayNew() As String, ByRef i As Long, ByRef j As Long) As String()
    Dim arr() As String
    Dim bound As Long
    On Error Resume Next
    If i >= 0 Then
        If j >= 0 Then 'both are greater or equal to zero
            'can only do the following comparison when i and j are greater or equal than zero
            If arrayOld(i) = arrayNew(j) Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i - 1, j - 1)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(0, 0) = arrayOld(i)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(0, bound + 1) = arrayOld(i)
                    End If
                    getDiffArr = arr
            Else
                If i = 0 Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i, j - 1)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(2, 0) = arrayNew(j)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(2, bound + 1) = arrayNew(j)
                    End If
                    getDiffArr = arr
                ElseIf c(i + 1, j - 1 + 1) >= c(i - 1 + 1, j + 1) Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i, j - 1)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(2, 0) = arrayNew(j)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(2, bound + 1) = arrayNew(j)
                    End If
                    getDiffArr = arr
                ElseIf j = 0 Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i - 1, j)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(1, 0) = arrayOld(i)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(1, bound + 1) = arrayOld(i)
                    End If
                    getDiffArr = arr
                ElseIf c(i + 1, j - 1 + 1) < c(i - 1 + 1, j + 1) Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i - 1, j)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(1, 0) = arrayOld(i)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(1, bound + 1) = arrayOld(i)
                    End If
                    getDiffArr = arr
                Else
                    getDiffArr = arr
                End If
            End If
        Else 'i is is greater or equal to zero
                If j = 0 Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i - 1, j)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(1, 0) = arrayOld(i)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(1, bound + 1) = arrayOld(i)
                    End If
                    getDiffArr = arr
                ElseIf c(i + 1, j - 1 + 1) < c(i - 1 + 1, j + 1) Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i - 1, j)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(1, 0) = arrayOld(i)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(1, bound + 1) = arrayOld(i)
                    End If
                    getDiffArr = arr
                Else
                    getDiffArr = arr
                End If
        End If
    Else
        If j >= 0 Then 'j is  greater than zero
                If i = 0 Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i - 1, j)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(2, 0) = arrayNew(j)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(2, bound + 1) = arrayNew(j)
                    End If
                    getDiffArr = arr
                ElseIf c(i + 1, j - 1 + 1) >= c(i - 1 + 1, j + 1) Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i, j - 1)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(2, 0) = arrayNew(j)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(2, bound + 1) = arrayNew(j)
                    End If
                    getDiffArr = arr
                Else
                    getDiffArr = arr
                End If
        Else 'none are greater than zero
                getDiffArr = arr
        End If
    End If
End Function




'collapses the array and shrinks the result to a smaller array
Private Function reduce_diff_array(arr() As String) As String()
    Dim state As Integer
    Dim i As Long
    Dim o As Long
    Dim tmpArr() As String
    Dim junks As Long
            
    state = -1
    o = 0
    junks = 0
    
    For i = LBound(arr, 2) To UBound(arr, 2)
        If Len(arr(0, i)) > 0 Then 'unmodified content
            If state = 0 Then 'previous element was in the same state
                arr(state, o) = arr(state, o) & arr(state, i)
                arr(state, i) = ""
            Else
                o = i
                junks = junks + 1
            End If
            state = 0
        End If
        If Len(arr(1, i)) > 0 Then 'removed content
            If state = 1 Then 'previous element was in the same state
                arr(state, o) = arr(state, o) & arr(state, i)
                arr(state, i) = ""
            Else
                o = i
                junks = junks + 1
            End If
            state = 1
        End If
        If Len(arr(2, i)) > 0 Then 'added content
            If state = 2 Then 'previous element was in the same state
                arr(state, o) = arr(state, o) & arr(state, i)
                arr(state, i) = ""
            Else
                o = i
                junks = junks + 1
            End If
            state = 2
        End If
    Next i
    
    'shrink array size
    ReDim tmpArr(2, junks - 1)
    o = 0
    For i = LBound(arr, 2) To UBound(arr, 2)
        If Len(arr(0, i)) > 0 Then 'unmodified content
            tmpArr(0, o) = arr(0, i)
            o = o + 1
        End If
        If Len(arr(1, i)) > 0 Then 'removed content
            tmpArr(1, o) = arr(1, i)
            o = o + 1
        End If
        If Len(arr(2, i)) > 0 Then 'added content
            tmpArr(2, o) = arr(2, i)
            o = o + 1
        End If
    Next i
    
    reduce_diff_array = tmpArr
    
End Function

The next step was to speed up the colorizing of the cell characters. This one was very easy as instead of colorizing each character by itself I could colorize each result junk as one operation.
Another speedup improvement was to reduce the number of junks by combining the junks to a few big junks.


The resulting output is not exactly like the diff generated by Word but pretty similar and very readable.

And here is the code for comparing two cells (both cells and the output cell must be in the same row):

Attribute VB_Name = "ColoredCellTextDiffNew"'requires "StringDiff" module


Option Base 1
Option Explicit
Const ColoredCellTextDiff_text = "ColoredCellTextDiff"  'name of the module
Const init_text = "vorbereiten"                         'initializing
Const character_text = "Zeichen"                        'character
Const of_text = "von"                                   'of


Public Sub cellTextDiff(row As Integer, oldCol As Integer, newCol As Integer, outCol As Integer)
    Dim tSht As Variant
    Dim outCell As Range
    Dim retArr() As Variant
    Dim StatusBar As String
    Dim diffData() As String
    Dim oldData As String
    Dim newData As String
    Dim i As Long
    Dim j As Long
    Dim laenge As Long
    Dim colorcode() As String
        
    Set tSht = ActiveSheet
    
    StatusBar = Application.StatusBar
    
    Application.StatusBar = StatusBar + " - " & ColoredCellTextDiff_text & " " & init_text
    DoEvents
    
    oldData = tSht.Cells(row, oldCol).Value2
    newData = tSht.Cells(row, newCol).Value2
    Set outCell = tSht.Cells(row, outCol)
    
    With outCell
        .Interior.Color = RGB(255, 255, 255)
        .Font.Color = RGB(0, 0, 0)
        .WrapText = True
        .Rows.AutoFit
        .VerticalAlignment = xlTop
        .Font.Underline = False
        .Font.Strikethrough = False
    End With
    
    'CASE 1: data is present only in revised document (addition)
    If (Len(oldData) = 0 And Not Len(newData) = 0) Then
        With outCell
            .Value2 = newData
            .Font.Color = RGB(0, 128, 128)
            .Font.Underline = True
        End With
    'CASE 2: data is present only in original document (deletion)
    ElseIf Not Len(oldData) = 0 And Len(newData) = 0 Then
        With outCell
            .Value2 = oldData
            .Font.Color = RGB(255, 0, 0)
            .Font.Strikethrough = True
        End With
    'CASE 3: data in original and revised documents is the same (copy)
    ElseIf StrComp(oldData, newData) = 0 And Not Len(newData) = 0 Then
        With outCell
            .Value2 = oldData
        End With
    'CASE 4: data in original and revised documents is different
    Else
        diffData = compare_strings(oldData, newData)
        outCell.Value2 = get_combined_diff_string(diffData)
        colorcode = get_markup_diff_string(diffData)
        
        j = 1
        For i = LBound(diffData, 2) To UBound(diffData, 2)
            Application.StatusBar = StatusBar + " - " & ColoredCellTextDiff_text & " " & character_text & " " & CStr(j) & " " & of_text & " " & CStr(Len(outCell.Value2))
            DoEvents
            laenge = Len(diffData(0, i))
            If laenge > 0 Then
                j = j + laenge
            End If
            laenge = Len(diffData(1, i))
            If laenge > 0 Then
                outCell.Characters(j, laenge).Font.Color = RGB(255, 0, 0)
                outCell.Characters(j, laenge).Font.Strikethrough = True
                j = j + laenge
            End If
            laenge = Len(diffData(2, i))
            If laenge > 0 Then
                outCell.Characters(j, laenge).Font.Color = RGB(0, 128, 128)
                outCell.Characters(j, laenge).Font.Underline = True
                j = j + laenge
            End If
        Next i
    End If
End Sub

 

[nbruno78]

Hello,
First of all, thank you very much for the macros shown here on a topic where it is very difficult to find a correct answer. DieterGsaid that he had limitations using special characters and upper/lower case strings to perform a word-by-word comparison of twho excel cells.

The used function stringToWordArray as shown below

Public Function stringToWordArray(ByRef str As String) As String()
    Dim regEx   ' Create variable.
    Dim aMatches, aMatch
    Dim a() As String
    Dim i As Long
    
    Set regEx = New RegExp   ' Create a regular expression.
    regEx.Pattern = "[^a-z]" 'lower case only
    regEx.Pattern = "([a-z]+)|([^a-z])" 'lower case only here, ignoring case anyway
    regEx.Global = True
    regEx.IgnoreCase = True
    
    Set aMatches = regEx.Execute(str)
    
    ReDim a(aMatches.Count - 1)
    For i = 0 To UBound(a)
        a(i) = aMatches.Item(i)
    Next i
    
    stringToWordArray = a
    
End Function

can be replaced by this one :

Public Function stringToWordArray(ByRef str As String) As String()
    Dim a() As String
    Dim i As Long
 
a = VBA.Split(str, " ")
For i = 0 To UBound(a)
a(i) = a(i) & " "
Next i
    
stringToWordArray = a
End Function

and then no longer creates restrictions.
Regards