Compare word by word between two cells and highlight difference

[Jmac2604]

Hi All,

I have a macro to compare words between cells from column B and D. Currently it is highlighting the matching words in column D. instead I want to highlight the column B. pasted the code below. Can someone pls help me on this?


Sub CompareWords()
Dim xStr() As String
Dim i As Long
Dim x As Long, y As Long

With ActiveSheet
For i = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
xStr = Split(.Cells(i, "B").Value, " ")
With .Cells(i, "D")
.Font.ColorIndex = 1
For x = LBound(xStr()) To UBound(xStr())
For y = 1 To Len(.Text)
If Mid(.Text, y, Len(xStr(x))) = xStr(x) Then

.Characters(y, Len(xStr(x))).Font.ColorIndex = 4

End If
Next y
Next x
End With
Next i
End With
MsgBox "completed"
End Sub

 

[Jmac2604]

This also I tried and thats the reason why the split should happen in column B only.

 

[JW00]

Hi, I had a go at adapting your code, I don't think it is ever going to be perfect because of the punctuation factor. I got it working to a degree, but there are compromise's, the nature of it makes it slow & in column B I had to introduce a space after brackets & slashes to separate the words from the punctuation, anyway you can see what you think & mess around with to get a compromise that you are happy with.

Function CleanCharCode(rng As Range)
Dim strTemp As String
Dim n As Long
    
    For n = 1 To Len(rng)
        Select Case Asc(Mid((rng), n, 1))
            Case 32, 39, 45, 48 To 59, 65 To 90, 97 To 122
                strTemp = strTemp & Mid((rng), n, 1)
        End Select
    Next
    CleanCharCode = strTemp
End Function
Sub CompareWords()
Dim ClStr() As String, xStr() As String
Dim wrd As String, wrd1 As String, wrd2 As String
Dim i As Long, j As Long
Dim x As Long, y As Long, z As Long
Dim rng As Range, Darr As Variant

    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False

    With ActiveSheet
        j = .Cells(.Rows.Count, "B").End(xlUp).Row
        Set rng = Range(Cells(2, 4), Cells(j, 4))
        Darr = rng.Value
        
    For i = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
        .Cells(i, "D") = Replace(.Cells(i, "D"), "/", " / ")
        .Cells(i, "B") = Replace(.Cells(i, "B"), "/", " / ")
        .Cells(i, "B") = Replace(.Cells(i, "B"), "(", "( ")
        .Cells(i, "B") = Replace(.Cells(i, "B"), ")", " )")
        .Cells(i, "B") = Replace(.Cells(i, "B"), "  ", " ")
        .Cells(i, "D") = CleanCharCode((.Cells(i, "D")))
        .Cells(i, "D") = Replace(.Cells(i, "D"), "  ", " ")
        xStr = Split(.Cells(i, "D").Value, " ")
        
    With .Cells(i, "B")
        .Font.ColorIndex = 1
        
    For x = LBound(xStr()) To UBound(xStr())
    For y = 1 To Len(.Text)
    
    If y = 1 Then
       wrd = xStr(x)
       z = 0
    ElseIf x = UBound(xStr()) Then
        wrd = " " & xStr(x)
        z = 1
    Else
       wrd = " " & xStr(x) & " "
       wrd1 = " " & xStr(x) & ","
       wrd2 = " " & xStr(x) & "."
       z = 1
    End If
    
    If LCase(Mid(.Text, y, Len(wrd))) = LCase(wrd) Or LCase(Mid(.Text, y, Len(wrd1))) = LCase(wrd1) Or LCase(Mid(.Text, y, Len(wrd2))) = LCase(wrd2) Then
    
    .Characters(y + z, Len(xStr(x))).Font.ColorIndex = 4
    
    End If
    Next y
    Next x
    End With
    Next i
    End With
    rng.Value = Darr

    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    
    MsgBox "completed"
    
End Sub