Highlight cell with many words, with duplicates from row with single words.

Hello meows,

This macro checks the contents of each in cell in column "A" that has entry against the words in a comma separated list in cell "B1". You can change these to match the locations you are using. They are marked in red. The words in the list are highlighted by bolding the font and changing it to red. It is not possible to highlight the background of each word individually.

Sub HighlightWords()

  Dim DSO As Object
  Dim I As Long
  Dim Key As String
  Dim R As Long
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wks As Worksheet
  Dim WordArray As Variant
  Dim WordCell As Range
  
    Set Wks = ActiveSheet
    Set WordCell = Wks.Range("B1")
    
    Set Rng = Wks.Range("A1")
    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Wks.Range(Rng, RngEnd))
    
      Set DSO = CreateObject("Scripting.Dictionary")
      DSO.CompareMode = vbTextCompare
      
      WordArray = Split(WordCell, ",")
      
     'Load the word list into the associative array
      For I = 0 To UBound(WordArray)
        If Not DSO.Exists(WordArray(I)) Then
           DSO.Add WordArray(I), 0
        End If
      Next I
      
     'Find words that match the word list
      For R = 1 To Rng.Rows.Count
        Key = Trim(Rng(R))
        If DSO.Exists(Key) Then
          If DSO(Key) = 0 Then
             I = InStr(1, WordCell, Key, vbTextCompare)
            'Change the text to bold and the color to red
             With WordCell.Characters(I, Len(Key)).Font
               .Bold = True
               .ColorIndex = 3  'Red
             End With
          End If
         'Increment number of matches
          DSO(Key) = DSO(Key) + 1
        End If
      Next R
     
   'Release object and memory
    Set DSO = Nothing
    
End Sub