mettre un mot ou une série de mots en couleur automatiquement dans un cellule Excel

Sub CoulCaractere()
Dim oRegExp As Object, oMatches As Object, oMatch As Object
Dim i As Long, Tmot(), Tcoul()
Dim Motif As String, Chaine As String, temp
Dim Data As Range, Liste As Range, C As Range

Set Data = Worksheets("Data").[A1].CurrentRegion
Set Liste = Range("Liste")

Data.Font.ColorIndex = xlAutomatic
ReDim Tmot(1 To Liste.Rows.Count): ReDim Tcoul(1 To Liste.Rows.Count)

Set oRegExp = CreateObject("vbscript.regexp")
With oRegExp
  .Global = True: .ignorecase = False: .Pattern = "[\(\)\[\]\.\?\{\}\*\|\\\+\$\^]" 'traitement des métacaractères

  For Each C In Liste
    i = i + 1: temp = C.Text
    If .test(temp) Then
      Set oMatches = .Execute(temp)
      For Each oMatch In oMatches: temp = Replace(temp, oMatch, "\" & oMatch, 1, 1): Next oMatch
    End If
    Tmot(i) = C.Text: Tcoul(i) = C.Font.Color: Motif = Motif & temp & "|"
  Next C
    
  Motif = "(" & Left(Motif, Len(Motif) - 1) & ")"
    
  .Pattern = Motif
    
  For Each C In Data
    Chaine = C.Text
    If .test(Chaine) Then
      Set oMatches = .Execute(Chaine)
      For Each oMatch In oMatches
        C.Characters(Start:=oMatch.firstindex + 1, _
        Length:=oMatch.Length).Font.Color = Application.Index(Tcoul, Application.Match(oMatch.Value, Tmot, 0))
      Next oMatch
    End If
  Next C
  
End With
End Sub

Set Data = Worksheets("Data").[A1].CurrentRegion