Highlight all multiple keywords within a cell, rather than just the first instance

Question

I'm developing a macro that can be run to check the compliance of line item descriptions against client billing requirements.

For example, certain words and symbols shouldn't be included at all in these line item descriptions. All instances of these non-compliant words and symbols should be highlighted to make it easy to see what needs to be removed/updated.

I have the following code which works well to highlight the non-compliant cells.

Unfortunately, it only colours the first instance of a keyword in the array. If there are multiple uses of "training" or ";" in the same cell then any of the subsequent instances in that same cell aren't coloured red.

Sub Highlight_Keywords()
    Dim ws As Worksheet
    Dim rngKeywords As Range
    Dim cell As Range
    Dim keyword As Variant

    Set ws = Sheets("Sheet2")
    Set rngKeywords = ws.Range("N2:N1000")

    For Each cell In rngKeywords
        For Each keyword In Array("Training", "Planning", "Filing", "Scanning", "Photocopying", "Printing", ";", ":", "&", "/")
            If InStr(1, cell.Value, keyword, vbTextCompare) > 0 Then
                cell.Interior.Color = RGB(255, 255, 204)
                cell.Characters(InStr(1, cell.Value, keyword, vbTextCompare), Len(keyword)).Font.Color = RGB(255, 0, 0)
            End If
        Next keyword
    Next cell
End Sub

I've found plenty of examples of VBA code that highlights a single keyword multiple times in the same cell, but haven't come across anything that works to highlight multiple instances of multiple keywords in the same cell. Any help would be greatly appreciated. Thank you!

Answer 1

• Use a loop to set font color for all instances in a cell
• InStr returns the position of the first occurrence of one string within another.
• Use Excel worksheet function Substitute to replace the first instance with the same amount of space.

Microsoft documentation:

InStr function

Sub Highlight_Keywords()
    Dim ws As Worksheet
    Dim rngKeywords As Range
    Dim cell As Range
    Dim keyword As Variant
    Set ws = Sheets("Sheet2")
    Set rngKeywords = ws.Range("N2:N1000")
    Dim sTxt As String, iLoc As Long
    For Each cell In rngKeywords
        sTxt = UCase(cell.Value)
        If Len(sTxt) > 0 Then
            For Each keyword In Array("Training", "Planning", "Filing", "Scanning", "Photocopying", "Printing", ";", ":", "&", "/")
                iLoc = InStr(1, sTxt, keyword, vbTextCompare)
                Do While iLoc > 0
                    cell.Characters(iLoc, Len(keyword)).Font.Color = RGB(255, 0, 0)
                    sTxt = Application.Substitute(sTxt, UCase(keyword), String(Len(keyword), " "), 1)
                    iLoc = InStr(1, sTxt, keyword, vbTextCompare)
                Loop
            Next keyword
        End If
    Next cell
End Sub