VBA Highlight cell if contains specific text

[AnnAnn]

Hi Everyone,
I've searched Google, YouTube, and this site and haven't found exactly what I need.
I have a macro in a workbook that runs on another open workbook; it uses the column name instead of letter/number via the FindColumn sub contained in the macro.
The column needs to highlight if it contains 33 specific words. I found this thread: VBA Delete rows if cell contains specific text, that I have tried to make work for me without success.
The code I currently am using highlights cells that do not contain any of the words in the code. And the code I modified from the referenced thread does not highlight anything.
I've posted both codes below. Can anyone help me correct it so that it only highlights cells that contain the specific words, please? All help is appreciated.
My current code:

Sub ServiceAddress1(ws As Worksheet, lastCol As Long, lastRow As Long)

Dim rng As Range, cell As Range
Dim Comment() As String
Dim colLtr As String

colLtr = FindColumn(ws, "Service Address 1", 2)

If colLtr = "Null" And lastRow > 2 Then

    Else
        
    Set rRange = ws.Range(colLtr & "3:" & colLtr & CStr(lastRow))
               
    
    
    ReDim Comment(33)
        Comment(0) = "Ste"
        Comment(1) = "Apt"
        Comment(2) = "Bsmt"
        Comment(3) = "Bldg"
        Comment(4) = "Dept"
        Comment(5) = "Flr"
        Comment(6) = "Frnt"
        Comment(7) = "Hngr"
        Comment(8) = "Key"
        Comment(9) = "Lot"
        Comment(10) = "Ofc"
        Comment(11) = "PH"
        Comment(12) = "Rear"
        Comment(13) = "Rm"
        Comment(14) = "Slip"
        Comment(15) = "Spc"
        Comment(16) = "Stop"
        Comment(17) = "Unit"
        Comment(18) = "Apartment"
        Comment(19) = "Basement"
        Comment(20) = "Building"
        Comment(21) = "Department"
        Comment(22) = "Floor"
        Comment(23) = "Front"
        Comment(24) = "Lobby"
        Comment(25) = "Upper"
        Comment(26) = "Suite"
        Comment(27) = "Space"
        Comment(28) = "Room"
        Comment(29) = "Penthouse"
        Comment(30) = "Office"
        Comment(31) = "Lower"
        Comment(32) = "Hangar"
        Comment(33) = ""
         
     For i = LBound(Comment) To UBound(Comment)
        Set Match = ws.Range(colLtr & "3:" & colLtr & CStr(lastRow)).Find(What:=Comment(i), LookIn:=xlValues, _
        LookAt:=xlPart, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    
            If Not Match Is Nothing Then
                firstAddress = Match.Address
                    Do
                    sPos = InStr(1, Match.Value, Comment(i))
                    sLen = Len(Comment(i))
                    Match.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(0, 0, 0)
                    Match.Interior.Color = RGB(255, 204, 0)
                    Set Match = ws.Range(colLtr & "3:" & colLtr & CStr(lastRow)).FindNext(Match)
                    Loop While Not Match Is Nothing And Match.Address <> firstAddress
                        
                        With ws.Range(colLtr & "2")
                            .Interior.Color = RGB(0, 0, 0)
                            .Font.Color = RGB(255, 255, 255)
                        End With
    
            End If
        Next i
End If
End Sub

Code from referenced thread that I modified:

Sub NewAdd1(ws As Worksheet, lastCol As Long, lastRow As Long)

Dim rng As Range, cell As Range
Dim Comment() As String
Dim colLtr As String
Dim RX As Object
Dim nc As Long, i As Long, k As Long
Dim a As Variant, b As Variant

colLtr = FindColumn(ws, "Service Address 1", 2)

If colLtr = "Null" And lastRow > 2 Then

    Else
        
    Set rRange = ws.Range(colLtr & "3:" & colLtr & CStr(lastRow))
    Set RX = CreateObject("VBScript.RegExp")
    RX.IgnoreCase = True
    RX.Pattern = "\colLtr(Apt|Bsmt|Bldg|Dept|Flr|Frnt|Hngr|Key|Lot|Ofc|Rear|PH|Rm|Slip|Spc|Stop|Unit|Apartment|Basement|Building|Department|Floor|Front|Lobby|Upper|Suite|Space|Room|Penthouse|Office|Lower|Hangar)\colLtr"
    nc = ws.Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).column + 1
    a = ws.Range(colLtr & "3:" & colLtr & CStr(lastRow))
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        If RX.Test(a(i, 1)) Then
          b(i, 1) = 1
          k = k + 1
        End If
    Next i
    If k > 0 Then
        ws.Cells.Interior.Color = RGB(255, 204, 0)
           With ws.Range(colLtr & "2")
            .Interior.Color = RGB(0, 0, 0)
            .Font.Color = RGB(255, 255, 255)
          End With
    End If
End If
End Sub

 

[DanteAmor]

The code I currently am using highlights cells that do not contain any of the words in the code

I tested your code and it works to highlight the cells that contain the text.

However, I made some changes, try and comment:

Sub ServiceAddress1(ws As Worksheet, lastCol As Long, lastRow As Long)
  Dim rRange As Range, Match As Range
  Dim firstAddress As String, colLtr As String
  Dim vComment As Variant
  Dim i As Long, sPos As Long, sLen As Long
  
  colLtr = FindColumn(ws, "Service Address 1", 2)
  
  If colLtr <> "" And lastRow > 2 Then
    Set rRange = ws.Range(colLtr & "3:" & colLtr & CStr(lastRow))
    ReDim Comment(33)
    vComment = Array("Ste", "Apt", "Bsmt", "Bldg", "Dept", "Flr", "Frnt", "Hngr", _
        "Key", "Lot", "Ofc", "PH", "Rear", "Rm", "Slip", "Spc", "Stop", "Unit", _
        "Apartment", "Basement", "Building", "Department", "Floor", "Front", "Lobby", _
        "Upper", "Suite", "Space", "Room", "Penthouse", "Office", "Lower", "Hangar")
    
    With ws.Range(colLtr & "2")
      .Interior.Color = RGB(0, 0, 0)
      .Font.Color = RGB(255, 255, 255)
    End With
    
    For i = LBound(vComment) To UBound(vComment)
      Set Match = rRange.Find(vComment(i), , xlValues, xlPart, , , False)
      
      If Not Match Is Nothing Then
        firstAddress = Match.Address
        Do
          sPos = InStr(1, Match.Value, vComment(i))
          sLen = Len(vComment(i))
          Match.Characters(Start:=sPos, Length:=sLen).Font.Color = vbBlack
          Match.Interior.Color = RGB(255, 204, 0)
          Set Match = rRange.FindNext(Match)
        Loop While Match.Address <> firstAddress
      End If
    Next i
  End If
End Sub

 

[AnnAnn]

I tested your code and it works to highlight the cells that contain the text.

However, I made some changes, try and comment:

Sub ServiceAddress1(ws As Worksheet, lastCol As Long, lastRow As Long)
  Dim rRange As Range, Match As Range
  Dim firstAddress As String, colLtr As String
  Dim vComment As Variant
  Dim i As Long, sPos As Long, sLen As Long
 
  colLtr = FindColumn(ws, "Service Address 1", 2)
 
  If colLtr <> "" And lastRow > 2 Then
    Set rRange = ws.Range(colLtr & "3:" & colLtr & CStr(lastRow))
    ReDim Comment(33)
    vComment = Array("Ste", "Apt", "Bsmt", "Bldg", "Dept", "Flr", "Frnt", "Hngr", _
        "Key", "Lot", "Ofc", "PH", "Rear", "Rm", "Slip", "Spc", "Stop", "Unit", _
        "Apartment", "Basement", "Building", "Department", "Floor", "Front", "Lobby", _
        "Upper", "Suite", "Space", "Room", "Penthouse", "Office", "Lower", "Hangar")
  
    With ws.Range(colLtr & "2")
      .Interior.Color = RGB(0, 0, 0)
      .Font.Color = RGB(255, 255, 255)
    End With
  
    For i = LBound(vComment) To UBound(vComment)
      Set Match = rRange.Find(vComment(i), , xlValues, xlPart, , , False)
    
      If Not Match Is Nothing Then
        firstAddress = Match.Address
        Do
          sPos = InStr(1, Match.Value, vComment(i))
          sLen = Len(vComment(i))
          Match.Characters(Start:=sPos, Length:=sLen).Font.Color = vbBlack
          Match.Interior.Color = RGB(255, 204, 0)
          Set Match = rRange.FindNext(Match)
        Loop While Match.Address <> firstAddress
      End If
    Next i
  End If
End Sub

Thanks, Dante. I used your code and it's still highlighting cells that do not contain the words listed. For example, it highlighted cells that contained 'Biesterfield', 'N Western Ave', 'W Foster Ave'.

 

[AnnAnn]

I tested your code and it works to highlight the cells that contain the text.

However, I made some changes, try and comment:

Sub ServiceAddress1(ws As Worksheet, lastCol As Long, lastRow As Long)
  Dim rRange As Range, Match As Range
  Dim firstAddress As String, colLtr As String
  Dim vComment As Variant
  Dim i As Long, sPos As Long, sLen As Long
 
  colLtr = FindColumn(ws, "Service Address 1", 2)
 
  If colLtr <> "" And lastRow > 2 Then
    Set rRange = ws.Range(colLtr & "3:" & colLtr & CStr(lastRow))
    ReDim Comment(33)
    vComment = Array("Ste", "Apt", "Bsmt", "Bldg", "Dept", "Flr", "Frnt", "Hngr", _
        "Key", "Lot", "Ofc", "PH", "Rear", "Rm", "Slip", "Spc", "Stop", "Unit", _
        "Apartment", "Basement", "Building", "Department", "Floor", "Front", "Lobby", _
        "Upper", "Suite", "Space", "Room", "Penthouse", "Office", "Lower", "Hangar")
   
    With ws.Range(colLtr & "2")
      .Interior.Color = RGB(0, 0, 0)
      .Font.Color = RGB(255, 255, 255)
    End With
   
    For i = LBound(vComment) To UBound(vComment)
      Set Match = rRange.Find(vComment(i), , xlValues, xlPart, , , False)
     
      If Not Match Is Nothing Then
        firstAddress = Match.Address
        Do
          sPos = InStr(1, Match.Value, vComment(i))
          sLen = Len(vComment(i))
          Match.Characters(Start:=sPos, Length:=sLen).Font.Color = vbBlack
          Match.Interior.Color = RGB(255, 204, 0)
          Set Match = rRange.FindNext(Match)
        Loop While Match.Address <> firstAddress
      End If
    Next i
  End If
End Sub

I ended up adding a space in front of the word in the ReDim Comment (33) section. Example: Comment(0) = " Ste" instead of Comment(0) = "Ste".

 

[DanteAmor]

Thanks, Dante. I used your code and it's still highlighting cells that do not contain the words listed. For example, it highlighted cells that contained 'Biesterfield', 'N Western Ave', 'W Foster Ave'.

I don't understand it, my code highlights the word that is inside the cell if it contains any of the listed words. You can put before and after images of the macro and finally, a third image, of the result you want.