Microsoft 365 différentes couleurs dans une cellule par vba

Sub Macro1()
'
' Macro1 Macro
'

'
    Range("A6").Select
    ActiveCell.FormulaR1C1 = "Voiture de sport"
    Range("A6").Select
    ActiveCell.FormulaR1C1 = "Voiture de sport"
    With ActiveCell.Characters(Start:=1, Length:=0).Font
        .Name = "Calibri"
        .FontStyle = "Normal"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With ActiveCell.Characters(Start:=1, Length:=8).Font
        .Name = "Calibri"
        .FontStyle = "Normal"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16776961
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With ActiveCell.Characters(Start:=9, Length:=8).Font
        .Name = "Calibri"
        .FontStyle = "Normal"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -11480942
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Range("A7").Select
End Sub

Sub test1()
    Dim Mots, couleurs
    Mots = Array("voiture", "de sport")    'l'array des mots
    couleurs = Array(vbRed, vbGreen)    'l'array des couleurs
    PutWordColorOnCell Mots, couleurs, Feuil1.[A4]    'appel de la fonction qui va faire le job
End Sub
'
Sub test2()
    Dim Mots, couleurs
    Mots = Array("toto", "titi", "riri", "fifi")    'l'array des mots
    couleurs = Array(vbRed, vbGreen, vbBlue, vbMagenta)    'l'array des couleurs
    PutWordColorOnCell Mots, couleurs, Feuil1.[A5]    'appel de la fonction qui va faire le job
End Sub
'
Sub test3()
    Dim Mots, couleurs
    Mots = Array("ca fait", "mal", "a la", "tete", "ce jargon")    'l'array des mots
    couleurs = Array(vbRed, vbGreen, vbBlue, vbMagenta, vbYellow)    'l'array des couleurs
    PutWordColorOnCell Mots, couleurs, Feuil1.[A6]    'appel de la fonction qui va faire le job
End Sub

Sub test4() '3 expressions et seulement les deux premieres couleurs
    Dim Mots, couleurs
    Mots = Array("moi j'aime pas ", "les couleurs", "ca pique les yeux")    'l'array des mots
    couleurs = Array(RGB(255, 100, 0), 1654236)   'l'array des couleurs
    PutWordColorOnCell Mots, couleurs, Feuil1.[A7]    'appel de la fonction qui va faire le job
End Sub

Sub test5() ' couleur une sur deux
    Dim Mots, couleurs
    Mots = Array("moi j'aime pas ", "les couleurs", "ca pique les yeux", "noir c'est noir il n'y a plus d'espoir")   'l'array des mots
    couleurs = Array(RGB(255, 100, 0), 0, 16534836, 0) 'l'array des couleurs
    PutWordColorOnCell Mots, couleurs, Feuil1.[A8]    'appel de la fonction qui va faire le job
End Sub
'
'
Function PutWordColorOnCell(wordArray, colorArray, cel As Range)
    Dim I&, X&, C&
    cel = Join(wordArray)
    For I = LBound(wordArray) To UBound(wordArray)
        X = InStr(1, cel.Value, wordArray(I), vbTextCompare)
       If I > UBound(colorArray) Then C = vbBlack Else C = colorArray(I)
       cel.Characters(X, Len(wordArray(I))).Font.Color = C
    Next
End Function