XL 2019 colorer les différents aliments avec un code VB pour macro de ce genre ?

VB:

Sub ColorerMotsRepas()

    Dim ws As Worksheet
    Dim cell As Range, mot As Range
    Dim PlageOmega As Range, PlageLegum As Range, PlageCheat As Range, PlageAutres As Range
    Dim startPos As Long

    Set ws = ThisWorkbook.Sheets("plg") ' <<< adapter si nécessaire

    ' Définir les plages des listes
    Set PlageOmega = ws.Range("AQ2:AQ20")
    Set PlageLegum = ws.Range("AR2:AR20")
    Set PlageCheat = ws.Range("AS2:AS20")
    Set PlageAutres = ws.Range("AT2:AT20")
  
    ' Parcourir toutes les lignes utilisées en colonne B
    For Each cell In ws.Range("B2:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row)
        If Not IsEmpty(cell.Value) Then
          
            ' Nettoyer d’abord la mise en forme
            cell.Font.Bold = False
            cell.Font.color = vbBlack

            ' Recherche dans chaque liste
            Call AppliquerCouleur(cell, PlageOmega, RGB(148, 0, 211)) ' Violet
            Call AppliquerCouleur(cell, PlageLegum, RGB(0, 112, 192)) ' Bleu
            Call AppliquerCouleur(cell, PlageCheat, RGB(255, 0, 0))   ' Rouge
            Call AppliquerCouleur(cell, PlageAutres, RGB(0, 176, 80)) ' Vert
        End If
    Next cell

    MsgBox "Coloration terminée !", vbInformation

End Sub


Private Sub AppliquerCouleur(ByVal cell As Range, ByVal liste As Range, ByVal couleur As Long)
    Dim mot As Range
    Dim startPos As Long
  
    For Each mot In liste
        If Trim(mot.Value) <> "" Then
            startPos = InStr(1, cell.Value, mot.Value, vbTextCompare)
            Do While startPos > 0
                ' Mise en forme partielle du mot trouvé
                cell.Characters(startPos, Len(mot.Value)).Font.color = couleur
                cell.Characters(startPos, Len(mot.Value)).Font.Bold = True
              
                ' Continuer la recherche (si plusieurs occurrences)
                startPos = InStr(startPos + Len(mot.Value), cell.Value, mot.Value, vbTextCompare)
            Loop
        End If
    Next mot
End Sub

Cliquez pour agrandir...