Compare two strings for similarity or highlight differences in Excel

[ka1234]

I have been trying to work with the VBA code provided by site "Extend Office" and shown below, which is intended to compare to text objects and highlight similarities or differences.

The problem I am having is that once the script recognizes a difference in the two text cells, it does not stop highlighting the following text. I would like this to only highlight the different words, and to not continue to highlight after a different word is found.

Can someone assist me with implementing a simple change to this code to make this work in this way?

Sub highlight()
    Dim xRg1 As Range
    Dim xRg2 As Range
    Dim xTxt As String
    Dim xCell1 As Range
    Dim xCell2 As Range
    Dim I As Long
    Dim J As Integer
    Dim xLen As Integer
    Dim xDiffs As Boolean
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
      xTxt = ActiveSheet.UsedRange.AddressLocal
    End If
lOne:
    Set xRg1 = Application.InputBox("Range A:", "Object Revision Identification", xTxt, , , , , 8)
    If xRg1 Is Nothing Then Exit Sub
    If xRg1.Columns.Count > 1 Or xRg1.Areas.Count > 1 Then
        MsgBox "Multiple ranges or columns have been selected ", vbInformation, "Kutools for Excel"
        GoTo lOne
    End If
lTwo:
    Set xRg2 = Application.InputBox("Range B:", "Kutools for Excel", "", , , , , 8)
    If xRg2 Is Nothing Then Exit Sub
    If xRg2.Columns.Count > 1 Or xRg2.Areas.Count > 1 Then
        MsgBox "Multiple ranges or columns have been selected ", vbInformation, "Kutools for Excel"
        GoTo lTwo
    End If
    If xRg1.CountLarge <> xRg2.CountLarge Then
       MsgBox "Two selected ranges must have the same numbers of cells ", vbInformation, "Kutools for Excel"
       GoTo lTwo
    End If
    xDiffs = (MsgBox("Click Yes to highlight similarities, click No to highlight differences ", vbYesNo + vbQuestion, "Kutools for Excel") = vbNo)
    Application.ScreenUpdating = False
    xRg2.Font.ColorIndex = xlAutomatic
    For I = 1 To xRg1.Count
        Set xCell1 = xRg1.Cells(I)
        Set xCell2 = xRg2.Cells(I)
        If xCell1.Value2 = xCell2.Value2 Then
            If Not xDiffs Then xCell2.Font.Color = vbRed
        Else
            xLen = Len(xCell1.Value2)
            For J = 1 To xLen
                If Not xCell1.Characters(J, 1).Text = xCell2.Characters(J, 1).Text Then Exit For
            Next J
            If Not xDiffs Then
                If J <= Len(xCell2.Value2) And J > 1 Then
                    xCell2.Characters(1, J - 1).Font.Color = vbRed
                End If
            Else
                If J <= Len(xCell2.Value2) Then
                    xCell2.Characters(J, Len(xCell2.Value2) - J + 1).Font.Color = vbRed
                End If
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

[mdmackillop]

If J <= Len(xCell2.Value2) Then
                    Dim c As Long
                    Do
                        xCell2.Characters(J + c, 1).Font.Color = vbRed
                        c = c + 1
                    Loop Until xCell2.Characters(J + c, 1).Text = " "
                End If

[ka1234]

If J <= Len(xCell2.Value2) Then
                    Dim c As Long
                    Do
                        xCell2.Characters(J + c, 1).Font.Color = vbRed
                        c = c + 1
                    Loop Until xCell2.Characters(J + c, 1).Text = " "
                End If

Is this intended to replace the current If Not xDiffs Then line or is it intended to follow it?

[ka1234]

Also, to clarify the issue; take this for example
Column A Cell 1:
Dog, Cat, Horse, Sheep

Column B Cell 1:
Dog, Cow, Horse, Mouse

What I would like the script to do is highlight the NEW additions in red as follows:

Column A Cell 1:
Dog, Cat, Horse, Sheep

Column B Cell 1:
Dog, Cow, Horse, Mouse


Currently the script would not recognize that "horse" is not a new addition, and simply follows the preceding new addition and highlights in red as follows:

Column A Cell 1:
Dog, Cat, Horse, Sheep

Column B Cell 1:
Dog, Cow, Horse, Mouse


I would like it to be able to handle going back and forth between highlighting a difference.

Would someone be able to help me identify what is or is not in the code currently that is causing this issue?

[mdmackillop]

Your original query did not specify your data. Is it a list of words, comma separated? What about Dog/Sheepdog? If not a list of words, please provide a realistic sample.

[ka1234]

Your original query did not specify your data. Is it a list of words, comma separated? What about Dog/Sheepdog? If not a list of words, please provide a realistic sample.

Yes this is very similar to the data I'm working with. They are words separated by commas. I also have columns with sentences that may have a word that was added or removed.

In your mentioned instance of "sheepdog" vs "dog" it would be sufficient for it to just color the word "sheep" red.

Please let me know if you need more information. I cannot figure out what the issue is.

[mdmackillop]

A simpler word by word comparison

Option Explicit

Sub Test()
Dim arr1, arr2, i&, x&
Dim rng1 As Range, rng2 As Range

Set rng1 = Cells(1, 1)
Set rng2 = rng1.Offset(,1)

arr1 = Split(Replace(rng1, ",", ""))
arr2 = Split(Replace(rng2, ",", ""))

rng2.Font.ColorIndex = 3
For i = 0 To UBound(arr1)
x = InStr(1, Cells(1, 2), arr1(i))
If x > 0 Then
rng2.Characters(Start:=x, Length:=Len(arr1(i)) + 1).Font.Color = 0
End If
Next

rng1.Font.ColorIndex = 3
For i = 0 To UBound(arr2)
x = InStr(1, rng1, arr2(i))
If x > 0 Then
rng1.Characters(Start:=x, Length:=Len(arr1(i)) + 1).Font.Color = 0
End If
Next

End Sub

[ka1234]

What would be the simplest way to apply this to a range of cells? I am trying to do a range of several rows and two columns that are not necessarily in column A.

[mdmackillop]

Dim cel As Range
    For Each cel In ActiveCell.CurrentRegion.Columns(1).Cells
    Set rng1 = cel

[nosliwde]

mdmackillop,
One: Thank you.
Two: I happen to get a "Subscript out of range" when I run this on:
A1=One three
B1=One two three

Runs fine if B1=One two four

[samantha7399]

If J <= Len(xCell2.Value2) Then
    Dim c As Long
    Do
    xCell2.Characters(J + c, 1).Font.Color = vbRed
    c = c + 1
    Loop Until xCell2.Characters(J + c, 1).Text = " "
End If

How can the code be altered to only highlight the different characters? I attempted the code change above but did not have much luck.
Current code example: SomethingNewBlue SomethingNewandBlue
What i'm hoping for: SomethingNewBlue SomethingNewandBlue

[georgiboy]

Hi Samantha,

I believe you should really start your own thread and not piggy back on another (I may be corrected by admin)

Anyway i was working on something for you but have now run out of time for the week, the attached works for what you need i believe but may not be the most efficient method.

Attached for reference

[SamT]

4 yo thread is now closed. Please start a new thread with your questions. you may link back to this thread.