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.