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

[anthoYS]

bonjour


les instructions sont dans le fichier (2 onglets).
Le second ce qui est attendu. Il sera sans doute nécessaire de le transformer en *.xlsm.
Le code VB n'est pas adapté, il est utile pour un autre fichier et onglet..
Donc il sera nécessaire de changer PlageOmega par PlageProteines, etc. etc.

A minima, une piste de départ, surtout les couleur, code couleur RGB(XXX, YYY, ZZZ) je ne sais pas à quoi correspond quoi...


Merci 🙂

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

 

[sylvanu]

Le problème serait si "eau" était avant "maquereau".
Arrivé à "maquereau", comme "eau" est déjà coloré, on n'y toucherait pas, donc on reviendrait au cas précédent.
Et là je ne vois guère de solution. 🙁

 

[anthoYS]

je comprends, merci une nouvelle fois :=)

Bonne fin de journée