Highlight just the Similar Text between 2 Cells

[rhelm]

Greetings All,
I'm looking for a VBA solution or function to help in this scenario. In A2 I have some text. I want to know if some of that text is in a long text string within B2. And if so, HIGHLIGHT that text so it is easily identifiable.

SOURCE	FOUND
GRANNY SMITH APPLE	ORANGES, PEACHES, CRANBERRIES, FIGS, CHERRIES, WATERMELON, APPLES, GRAPES, BANANAS

 

[Fluff]

How about

Sub rhelm()
   Dim Cl As Range
   Dim Sp As Variant
   Dim i As Long, Pos As Long
   
   For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
      Sp = Split(Cl.Value)
      For i = 0 To UBound(Sp)
         Pos = InStr(1, Cl.Offset(, 1).Value, Sp(i), vbTextCompare)
         If Pos > 0 Then Cl.Offset(, 1).Characters(Pos, Len(Sp(i))).Font.Color = vbRed
      Next i
   Next Cl
End Sub

 

[rhelm]

How about

Sub rhelm()
   Dim Cl As Range
   Dim Sp As Variant
   Dim i As Long, Pos As Long
  
   For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
      Sp = Split(Cl.Value)
      For i = 0 To UBound(Sp)
         Pos = InStr(1, Cl.Offset(, 1).Value, Sp(i), vbTextCompare)
         If Pos > 0 Then Cl.Offset(, 1).Characters(Pos, Len(Sp(i))).Font.Color = vbRed
      Next i
   Next Cl
End Sub

@Fluff yeah, that'll work! Thank you. Can you tell me how I might modify it so it's not dependent on A2? For example, I'd like to select 2 random columns and run highlight down both checking cell to cell on each row.
Regards,
rhelm

 

[Fluff]

Select the column with the values to be found first & try this

Sub rhelm()
   Dim Cl As Range, Rng1 As Range, Rng2 As Range
   Dim Sp As Variant
   Dim i As Long, Pos As Long
   
   With Selection
      If .Areas.Count > 1 Then
         Set Rng1 = .Areas(1)
         Set Rng2 = .Areas(2)
      Else
         Set Rng1 = .Columns(1)
         Set Rng2 = .Columns(2)
      End If
   End With
   For Each Cl In Range(Rng1(1), Rng1.Range("A" & Rows.Count).End(xlUp))
      Sp = Split(Cl.Value)
      For i = 0 To UBound(Sp)
         Pos = InStr(1, Rng2.Range("A" & Cl.Row).Value, Sp(i), vbTextCompare)
         If Pos > 0 Then Rng2.Range("A" & Cl.Row).Characters(Pos, Len(Sp(i))).Font.Color = vbRed
      Next i
   Next Cl
End Sub

 

[Ashok Koparkar]

Sub rhelm()
   Dim Cl As Range
   Dim Sp As Variant
   Dim i As Long, Pos As Long
  
   For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
      Sp = Split(Cl.Value)
'RESET FONT COLOUR TO BLACK
      Cl.Offset(, 1).Font.Color = vbBlack
      For i = 0 To UBound(Sp)
         Pos = InStr(1, Cl.Offset(, 1).Value, Sp(i), vbTextCompare)
         If Pos > 0 Then Cl.Offset(, 1).Characters(Pos, Len(Sp(i))).Font.Color = vbRed
      Next i
   Next Cl
End Sub

 

[rhelm]

Select the column with the values to be found first & try this

Sub rhelm()
   Dim Cl As Range, Rng1 As Range, Rng2 As Range
   Dim Sp As Variant
   Dim i As Long, Pos As Long
  
   With Selection
      If .Areas.Count > 1 Then
         Set Rng1 = .Areas(1)
         Set Rng2 = .Areas(2)
      Else
         Set Rng1 = .Columns(1)
         Set Rng2 = .Columns(2)
      End If
   End With
   For Each Cl In Range(Rng1(1), Rng1.Range("A" & Rows.Count).End(xlUp))
      Sp = Split(Cl.Value)
      For i = 0 To UBound(Sp)
         Pos = InStr(1, Rng2.Range("A" & Cl.Row).Value, Sp(i), vbTextCompare)
         If Pos > 0 Then Rng2.Range("A" & Cl.Row).Characters(Pos, Len(Sp(i))).Font.Color = vbRed
      Next i
   Next Cl
End Sub

@Fluff yep, that's the one! Much appreciated!
Regards,
rhelm

 

[Fluff]

You're welcome & thanks for the feedback.

 

[CF64]

You're welcome & thanks for the feedback.

Hello @Fluff, I'm highlighting a column (column 1) and have placed the column I would like to see highlighted values (column 2) next to it. I run the code and it is highlighting every word in column (2). Does the text in the highlighted column (column 1) need to be comma delimited or can it be a block of text with spaces, returns, etc?

I'm using this code:
Sub rhelm()
Dim Cl As Range, Rng1 As Range, Rng2 As Range
Dim Sp As Variant
Dim i As Long, Pos As Long

With Selection
If .Areas.Count > 1 Then
Set Rng1 = .Areas(1)
Set Rng2 = .Areas(2)
Else
Set Rng1 = .Columns(1)
Set Rng2 = .Columns(2)
End If
End With
For Each Cl In Range(Rng1(1), Rng1.Range("A" & Rows.Count).End(xlUp))
Sp = Split(Cl.Value)
For i = 0 To UBound(Sp)
Pos = InStr(1, Rng2.Range("A" & Cl.Row).Value, Sp(i), vbTextCompare)
If Pos > 0 Then Rng2.Range("A" & Cl.Row).Characters(Pos, Len(Sp(i))).Font.Color = vbRed
Next i
Next Cl
End Sub


Thank you,

 

[CF64]

Hello @Fluff, I'm highlighting a column (column 1) and have placed the column I would like to see highlighted values (column 2) next to it. I run the code and it is highlighting every word in column (2). Does the text in the highlighted column (column 1) need to be comma delimited or can it be a block of text with spaces, returns, etc?

I'm using this code:
Sub rhelm()
Dim Cl As Range, Rng1 As Range, Rng2 As Range
Dim Sp As Variant
Dim i As Long, Pos As Long

With Selection
If .Areas.Count > 1 Then
Set Rng1 = .Areas(1)
Set Rng2 = .Areas(2)
Else
Set Rng1 = .Columns(1)
Set Rng2 = .Columns(2)
End If
End With
For Each Cl In Range(Rng1(1), Rng1.Range("A" & Rows.Count).End(xlUp))
Sp = Split(Cl.Value)
For i = 0 To UBound(Sp)
Pos = InStr(1, Rng2.Range("A" & Cl.Row).Value, Sp(i), vbTextCompare)
If Pos > 0 Then Rng2.Range("A" & Cl.Row).Characters(Pos, Len(Sp(i))).Font.Color = vbRed
Next i
Next Cl
End Sub


Thank you,

Hi, @Fluff please disregard my last, I got it to work! Thank you

 

[CF64]

Hi @Fluff, I spoke to soon . In some cells it highlighted only certain words appropriately, in other cells it highlighted all words. Any suggestions are greatly appreciated. Thank you