Option Explicit
'=====================================================================
' Macro : ColorerMotsRepas
' Objectif : mettre en couleur les mots-clés présents dans les
' colonnes AQ-AT (Omega 3, Légumineuses, Cheat-Meal, …)
' pour chaque ligne de la colonne B (repas).
'=====================================================================
Public Sub ColorerMotsRepas()
Dim ws As Worksheet
Dim cell As Range
Dim lastRow As Long
Dim PlageProteines As Range ' J2:J29 ? Prot
Dim PlageGraisses As Range ' K2:K29 ? Graisses
Dim PlageGlucides As Range ' L2:L29 ? Glucides
Dim PlageFibres As Range ' M2:M29 ? Fibres
Dim PlageBoissons As Range ' N2:N29 ? Boissons
'--- 1?? Feuille cible -------------------------------------------------
Set ws = ThisWorkbook.Sheets("plg") ' ? adapte si ton onglet porte un autre nom
'--- 2?? Définition des listes -----------------------------------------
With ws
Set PlageProteines = .Range("J2:J29")
Set PlageGraisses = .Range("K2:K29")
Set PlageGlucides = .Range("L2:L29")
Set PlageFibres = .Range("M2:M29")
Set PlageBoissons = .Range("N2:N29")
End With
'--- 3?? Dernière ligne réellement remplie en colonne B ---------------
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
'--- 4?? Parcours de chaque cellule de la colonne B --------------------
For Each cell In ws.Range("B2:B" & lastRow)
If Len(Trim(cell.Value)) = 0 Then GoTo ProchaineCellule 'ligne vide ? on passe
'--- 4.1?? Remise à zéro du format ---------------------------------
With cell.Font
.Bold = False
.Color = vbBlack
End With
'--- 4.2?? Recherche et coloration ---------------------------------
Call AppliquerCouleur(cell, PlageProteines, RGB(148, 0, 211)) ' violet
Call AppliquerCouleur(cell, PlageGraisses, RGB(0, 112, 192)) ' bleu
Call AppliquerCouleur(cell, PlageGlucides, RGB(255, 0, 0)) ' rouge
Call AppliquerCouleur(cell, PlageFibres, RGB(0, 176, 80)) ' vert
Call AppliquerCouleur(cell, PlageBoissons, RGB(255, 116, 100)) ' ???
ProchaineCellule:
Next cell
MsgBox "Coloration terminée !", vbInformation
End Sub
'=====================================================================
' Sous-procédure qui colore chaque occurrence d’un mot trouvé
'=====================================================================
Private Sub AppliquerCouleur(ByVal cell As Range, ByVal liste As Range, ByVal couleur As Long)
Dim mot As Range
Dim startPos As Long
Dim texteCell As String
texteCell = cell.Value
For Each mot In liste
If Len(Trim(mot.Value)) = 0 Then GoTo MotSuivant 'ignore les cellules vides de la liste
startPos = InStr(1, texteCell, mot.Value, vbTextCompare)
Do While startPos > 0
With cell.Characters(startPos, Len(mot.Value)).Font
.Color = couleur
.Bold = True
End With
'recherche la prochaine occurrence du même mot
startPos = InStr(startPos + Len(mot.Value), texteCell, mot.Value, vbTextCompare)
Loop
MotSuivant:
Next mot
End Sub
'=====================================================================
' (Optionnel) Conversion du texte de date en vraie date Excel
'=====================================================================
Public Function ParseDate(txt As String) As Date
'Exemple d’entrée : Tue Oct 10 2017 02:00:00 GMT+0200 (heure d’été d’Europe centrale)
Dim parts() As String, d As Date, hh As Long, mm As Long, ss As Long
On Error GoTo ErrHandler
parts = Split(txt, " ")
'parts(1)=Oct, parts(2)=10, parts(3)=2017, parts(4)=02:00:00
d = DateSerial(CLng(parts(3)), MonthNameToNumber(parts(1)), CLng(parts(2)))
hh = CLng(Split(parts(4), ":")(0))
mm = CLng(Split(parts(4), ":")(1))
ss = CLng(Split(parts(4), ":")(2))
ParseDate = DateAdd("h", hh, DateAdd("n", mm, DateAdd("s", ss, d)))
Exit Function
ErrHandler:
ParseDate = 0 'renvoie 0 si la conversion échoue
End Function
Private Function MonthNameToNumber(m As String) As Integer
Select Case LCase(m)
Case "jan": MonthNameToNumber = 1
Case "feb": MonthNameToNumber = 2
Case "mar": MonthNameToNumber = 3
Case "apr": MonthNameToNumber = 4
Case "may": MonthNameToNumber = 5
Case "jun": MonthNameToNumber = 6
Case "jul": MonthNameToNumber = 7
Case "aug": MonthNameToNumber = 8
Case "sep": MonthNameToNumber = 9
Case "oct": MonthNameToNumber = 10
Case "nov": MonthNameToNumber = 11
Case "dec": MonthNameToNumber = 12
Case Else: MonthNameToNumber = 0
End Select
End Function
