Compare words in 2 cells highlighting the same words or different words

[burniksapwet]

I found this code online guys and I need help updating it.

Sub Macro1()
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:", "Kutools for Excel", 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

What this will do is lets say you have this statement in column A and column B

A____________________________B
Jason is driving there_______Jason is walking there

If you compare A to B then it will highlight that the same words "Jason is" and it will turn the text red. What i want it to do is basically search of every word in column A (or whatever column you select) and not just turn the text up to the point that they are similar. So in this instance I want the macro to work to were it will highlight and turn the text red for the word there because it is present in both columns regardless of whats in between them.

The result will be like this

A____________________________B
Jason is driving there_______Jason is walking there

Im hoping to get something like this
A____________________________B
Jason is driving there_______Jason is walking there

I hope someone will be able to help me out with this problem and would like to thank all who are willing to help in advance. Thank you so much.

 

[Peter_SSs]

Easiest way would be to make an exact copy of the previous macro but ..

• Change the name of the copy to, say Sub Matching_Words_A_B()
• Replace one line of code as shown below

Resp = InputBox("Enter the two column letters separated by a comma. e.g. C,G")
Resp = "A,B"

 

[burniksapwet]

Easiest way would be to make an exact copy of the previous macro but ..

• Change the name of the copy to, say Sub Matching_Words_A_B()
• Replace one line of code as shown below

Resp = InputBox("Enter the two column letters separated by a comma. e.g. C,G")
Resp = "A,B"

Perfect. We now have it working flawlessly. Hopefully we don’t encounter any hiccups but I would like to thank you for being patient with me and helping me out all throughout this request. Thank you.

 

[Peter_SSs]

You're welcome. That is what the forum is for.

 

[robinsonsfurniture]

Thanks for this solution it's working great for us and highlighling the duplicated words perfectly
One further question, having highlighted the duplicates between each column in red using the macro , is it possible to copy and paste the remaining black text in a separate column to give the result below

New Title	Title_EBAY_EBAY1_UK	Remaining Words
2 Door Mirrored Wardrobe	German Wimex Imago Oak 2 Door 90cm Wardrobe with mirrors	German Wimex Imago Oak 90cm with mirrors
READY ASSEMBLED Wardrobe Oak	ASSEMBLED German Wimex Imago Oak 2 Door 90cm Mirror Wardrobe	German Wimex Imago 2 Door 90cm Mirror

Kindest regards
Colin

 

[Peter_SSs]

is it possible to copy and paste the remaining black text in a separate column to give the result below

Welcome to the MrExcel board!

Not sure how you chose to identify the 2 columns, but see if this helps.
I have assumed data in columns A:B with remaining words in col C.

Sub Remaining_Words()
  Dim RX As Object, M As Object
  Dim a As Variant, b As Variant, itm As Variant, Cols As Variant
  Dim Resp As String
  Dim i As Long
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  RX.Pattern = "[A-Z]{1,2}\,[A-Z]{1,2}"
'  Resp = InputBox("Enter the two column letters separated by a comma. e.g. C,G")
  Resp = "A,B"
  If RX.Test(Replace(Resp, " ", "")) Then
    Application.ScreenUpdating = False
    Cols = Split(Replace(Resp, " ", ""), ",")
    a = Range(Cols(0) & 1, Range(Cols(0) & Rows.Count).End(xlUp)).Value
    With Range(Cols(1) & 1).Resize(UBound(a))
      .Font.Color = vbBlack
      b = .Value
      For i = 2 To UBound(a)
        RX.Pattern = "(^| )(" & Replace(Replace(Replace(Application.Trim(a(i, 1)), "(", "\("), ")", "\)"), " ", "|") & ")(?= |$)"
        Set M = RX.Execute(b(i, 1))
        With .Cells(i, 1)
          For Each itm In M
            .Characters(itm.firstindex + 1, Len(itm)).Font.Color = vbRed
          Next itm
        End With
        b(i, 1) = LTrim(RX.Replace(b(i, 1), ""))
      Next i
    End With
    With Range("C1").Resize(UBound(b))
      .Value = b
      .Cells(1).Value = "Remaining Words"
      .Columns.AutoFit
    End With
    Application.ScreenUpdating = True
  Else
    MsgBox "Not a valid entry"
  End If
End Sub

 

[robinsonsfurniture]

Welcome to the MrExcel board!

Not sure how you chose to identify the 2 columns, but see if this helps.
I have assumed data in columns A:B with remaining words in col C.

Sub Remaining_Words()
  Dim RX As Object, M As Object
  Dim a As Variant, b As Variant, itm As Variant, Cols As Variant
  Dim Resp As String
  Dim i As Long
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  RX.Pattern = "[A-Z]{1,2}\,[A-Z]{1,2}"
'  Resp = InputBox("Enter the two column letters separated by a comma. e.g. C,G")
  Resp = "A,B"
  If RX.Test(Replace(Resp, " ", "")) Then
    Application.ScreenUpdating = False
    Cols = Split(Replace(Resp, " ", ""), ",")
    a = Range(Cols(0) & 1, Range(Cols(0) & Rows.Count).End(xlUp)).Value
    With Range(Cols(1) & 1).Resize(UBound(a))
      .Font.Color = vbBlack
      b = .Value
      For i = 2 To UBound(a)
        RX.Pattern = "(^| )(" & Replace(Replace(Replace(Application.Trim(a(i, 1)), "(", "\("), ")", "\)"), " ", "|") & ")(?= |$)"
        Set M = RX.Execute(b(i, 1))
        With .Cells(i, 1)
          For Each itm In M
            .Characters(itm.firstindex + 1, Len(itm)).Font.Color = vbRed
          Next itm
        End With
        b(i, 1) = LTrim(RX.Replace(b(i, 1), ""))
      Next i
    End With
    With Range("C1").Resize(UBound(b))
      .Value = b
      .Cells(1).Value = "Remaining Words"
      .Columns.AutoFit
    End With
    Application.ScreenUpdating = True
  Else
    MsgBox "Not a valid entry"
  End If
End Sub

Absolutely spot on and thanks again for your help
kindest regards
Colin

 

[Peter_SSs]

Absolutely spot on and thanks again for your help

You're welcome. Thanks for the follow-up.