How to change partial font color in a cell which is found by another cell?

[Rajib]

I want to change the partial font color (red) found in B1 match by column A.

 

[Marc L]

​

Use this forum tool XL2BB to share your before state worksheet and accordingly your expected result worksheet …​

 

[Fluff]

Hi & welcome to MrExcel.
Is this for Excel or Google Sheets?

 

[Rajib]

Google Sheets, but if this process is much easier in excel then please suggest the process. Thank you #Fluff

 

[Peter_SSs]

In Excel, it could be done like this.

Sub HighlighText()
  Dim RX As Object, M As Object
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = Join(Application.Transpose(Range("A1", Range("A" & Rows.Count).End(xlUp))), "|")
  With Range("B1")
    For Each M In RX.Execute(.Value)
      .Characters(M.FirstIndex + 1, Len(M)).Font.Color = vbRed
    Next M
  End With
End Sub

 

[Rajib]

Awesome. Thank you for your solution.
I faced a couple of problems here.

1. It is case sensitive, but I need it for both cases (Upper & Lower)
2. If some word index first then that word is not found with the next word. It occurs when combining 3 words where the middle word is the same. In this case, the first 2 words combine and the second and third word is not combined.

Would you please solve it?

 

[Peter_SSs]

It is case sensitive, but I need it for both cases (Upper & Lower)

That part is easy. Just add this line

  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True

If some word index first then that word is not found with the next word. It occurs when combining 3 words where the middle word is the same. In this case, the first 2 words combine and the second and third word is not combined.

If you are saying that "figurines" should also be coloured then that will require a much less efficient code. That would not be a problem if there is only one cell to process but could add significant time if there are in fact multiple cells in column B to process. Anyway, try this version.

Sub HighlighText_v2()
  Dim RX As Object, M As Object
  Dim a As Variant, itm As Variant
  Dim i As Long
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
  With Range("B1")
    For i = 1 To UBound(a)
      RX.Pattern = a(i, 1)
      For Each M In RX.Execute(.Value)
        .Characters(M.FirstIndex + 1, Len(M)).Font.Color = vbRed
      Next M
    Next i
  End With
End Sub

 

[Rajib]

Perfect, thanks much. It's worked.
Is this any other process to execute this in multiple cells in column B or multiple columns like B, C, D....H? I need it for 8 cells. it can be different columns or cells of the rows.

 

[Peter_SSs]

process to execute this in multiple cells in column B or multiple columns like B, C, D....H? I need it for 8 cells

What about something like this?

Sub HighlighText_v3()
  Dim RX As Object, M As Object
  Dim a As Variant, itm As Variant
  Dim i As Long
  Dim c As Range
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
  For Each c In Range("B1:C4")
    With c
      For i = 1 To UBound(a)
        RX.Pattern = a(i, 1)
        For Each M In RX.Execute(.Value)
          .Characters(M.FirstIndex + 1, Len(M)).Font.Color = vbRed
        Next M
      Next i
    End With
  Next c
End Sub

 

[Rajib]

Thanks muccchhh... worked perfectly.