Highlight specific text in range based on value of three cells

[Mylarbi]

Hi all, I will appreciate help with this please.
I have the following vba code working where for any text put in cell M2, it is searched in the range M5:M55 and anywhere the text is found, it is highlighted.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    If Target.Count > 1 Then Exit Sub
    SelectAndChange (Target)
 
End Sub
 
Private Sub SelectAndChange(strValue As String)
 
    Dim rngCell     As Range
    Dim rngRange    As Range
    Dim strLookFor  As String
    Dim arrChar     As Variant
    Dim lngCounter  As Long
 
    If strValue = vbNullString Then Exit Sub
    Application.EnableEvents = False
 
    Set rngRange = Range("M5:M555")
    rngRange.Font.Color = vbBlack
    strLookFor = Range("M2").Value
 
    For Each rngCell In rngRange
        For lngCounter = 1 To Len(rngCell) - Len(strLookFor) + 1
            If Mid(rngCell, lngCounter, Len(strLookFor)) = strLookFor Then
                rngCell.Characters(lngCounter, Len(strLookFor)).Font.Color = vbRed
            End If
        Next lngCounter
    Next rngCell
 
    Application.EnableEvents = True
 
End Sub

I need help to improve this where the search criteria, currently using cell M2, is expanded to include value of cells N2 and O2.
The search range should remain M5:M55
Thanks

 

[DanteAmor]

How about:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Count > 1 Then Exit Sub
  SelectAndChange (Target)
End Sub
 
Private Sub SelectAndChange(strValue As String)
   Dim rngCell     As Range
   Dim rngRange    As Range
   Dim rngLooks    As Range
   Dim strLookFor  As String
   Dim arrChar     As Variant
   Dim lngCounter  As Long

   If strValue = vbNullString Then Exit Sub
   Application.EnableEvents = False

   Set rngRange = Range("M5:M555")
   rngRange.Font.Color = vbBlack

   For Each rngCell In rngRange
     For Each rngLooks In Range("M2:O2")
       strLookFor = rngLooks.Value
       For lngCounter = 1 To Len(rngCell) - Len(strLookFor) + 1
         If Mid(rngCell, lngCounter, Len(strLookFor)) = strLookFor Then
           rngCell.Characters(lngCounter, Len(strLookFor)).Font.Color = vbRed
         End If
       Next lngCounter
     Next rngLooks
   Next rngCell
   Application.EnableEvents = True
End Sub

 

[Mylarbi]

Hi DanteAmor, thanks for the help but it doesn't work as expected. First it kind of freezes Excel for about two minutes (I have only 500 rows of content). Then after it unfreezes, the result is that it has changed the entire content of cells containing value of M2 to red. This is not the expected results.
What I am trying to achieve is that if cell M2 is "London", cell N2 is "Tokyo" and cell O2 is "Nevada"; then I want only these texts if appearing in the M5:M555 range to change to red.
So for example: in cell M5, I get, [the team will leave London and travel to Tokyo for a week before returning to Nevada.]
Thanks

 

[Peter_SSs]

t is searched in the range M5:M55

search range should remain M5:M55

Set rngRange = Range("M5:M555")

I want only these texts if appearing in the M5:M555

Firstly, please be careful with the information that you give us as that is all we have to go on. Two references to 51 rows and two to 551 rows is somewhat confusing. ?

Anyway, see how this goes with your Windows 365 version. I don't believe that it will work on a Mac.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim RX As Object, M As Object
  Dim a As Variant
  Dim i As Long
  
  If Not Intersect(Target, Union(Range("M2:O2"), Range("M5:M555"))) Is Nothing Then
    Set RX = CreateObject("VBScript.RegExp")
    RX.Global = True
    RX.Pattern = Application.TextJoin("|", 1, Range("M2:O2"))
    Application.ScreenUpdating = False
    With Range("M5:M555")
      .Font.ColorIndex = xlAutomatic
      a = .Value
      For i = 1 To UBound(a)
        For Each M In RX.Execute(a(i, 1))
          .Cells(i).Characters(M.firstindex + 1, M.Length).Font.Color = vbRed
        Next M
      Next i
    End With
    Application.ScreenUpdating = True
  End If
End Sub

 

[Mylarbi]

Hi Peter_SSs, first apologies for the typo. I meant to refer to range M5:M555 in my original question.
Your suggested code works as expected. Thanks for the help.
The remaining issue is that it is case sensitive so if a word like "engineer" is typed in cell M2, it does not pick out "Engineer" in the range M5:M555.
Can the code be adjusted to make the function case insensitive instead? Thanks

 

[Mylarbi]

Also, the execution takes quite some time to finish. In most cases, the range M5:M555 would have been filtered.
Can the code be such that the search applies to only visible cells in the range?
I believe that will shorten the length of time the function takes to complete. Thanks

 

[DanteAmor]

First it kind of freezes Excel for about two minutes (I have only 500 rows of content)

Try this. With 1500 records the result is immediate.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, c As Range
  If Target.CountLarge > 1 Then Exit Sub
  Set rng = Intersect(Target, Range("M2:O2, M5:M" & Rows.Count))
  If Not rng Is Nothing Then
    SelectAndChange rng.Value
  End If
End Sub
 
Private Sub SelectAndChange(strValue As String)
  Dim rngLooks    As Range, f As Range, r As Range
  Dim strLookFor  As String, cell As String
  Dim lngCounter  As Long
  
  Application.ScreenUpdating = False
  Set r = Range("M5", Range("M" & Rows.Count).End(3))
  r.Font.Color = vbBlack
  
  For Each rngLooks In Range("M2:O2")
    strLookFor = LCase(rngLooks.Value)
    Set f = r.Find(strLookFor, , xlValues, xlPart, , , False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        For lngCounter = 1 To Len(f) - Len(strLookFor) + 1
          If LCase(Mid(f, lngCounter, Len(strLookFor))) = strLookFor Then
            f.Characters(lngCounter, Len(strLookFor)).Font.Color = vbRed
            lngCounter = lngCounter + Len(strLookFor) - 1
          End If
        Next lngCounter
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next rngLooks
  Application.ScreenUpdating = True
End Sub

 

[Mylarbi]

Try this. With 1500 records the result is immediate.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, c As Range
  If Target.CountLarge > 1 Then Exit Sub
  Set rng = Intersect(Target, Range("M2:O2, M5:M" & Rows.Count))
  If Not rng Is Nothing Then
    SelectAndChange rng.Value
  End If
End Sub
 
Private Sub SelectAndChange(strValue As String)
  Dim rngLooks    As Range, f As Range, r As Range
  Dim strLookFor  As String, cell As String
  Dim lngCounter  As Long
 
  Application.ScreenUpdating = False
  Set r = Range("M5", Range("M" & Rows.Count).End(3))
  r.Font.Color = vbBlack
 
  For Each rngLooks In Range("M2:O2")
    strLookFor = LCase(rngLooks.Value)
    Set f = r.Find(strLookFor, , xlValues, xlPart, , , False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        For lngCounter = 1 To Len(f) - Len(strLookFor) + 1
          If LCase(Mid(f, lngCounter, Len(strLookFor))) = strLookFor Then
            f.Characters(lngCounter, Len(strLookFor)).Font.Color = vbRed
            lngCounter = lngCounter + Len(strLookFor) - 1
          End If
        Next lngCounter
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next rngLooks
  Application.ScreenUpdating = True
End Sub

Hi @DanteAmor this is splendid. It highlights the texts as expected and better still, it works without any lag. Thank you very much.

 

[DanteAmor]

this is splendid. It highlights the texts as expected and better still, it works without any lag. Thank you very much.

I'm glad to help you. Thanks for the feedback.

 

[Mylarbi]

I'm glad to help you. Thanks for the feedback.

The private sub seems to be triggered unnecessarily when I am working on the sheet. Please is it possible to turn it into a standard macro which is only activates when it is called with 'Run' or a shortcode or a button?