Sub CompilAllergenes()
Dim derlig&, dercol&, i&, j&, nlig&
Dim base, res(), Famille$, Coul$
Application.ScreenUpdating = False
'lecture du tableau base
base = Sheets("Base").Range("d1").CurrentRegion.Value
' tableau résultat, même dimension que le tableau base
ReDim res(1 To UBound(base, 1), 1 To UBound(base, 2))
With Sheets("Tab")
' effacement du tableau de la feuille "Tab"
.Range("d1").CurrentRegion.Clear
' écriture des deux lignes d'en-tête de base
' dans le tableau res
For i = 1 To 2
For j = 1 To UBound(base, 2)
res(i, j) = base(i, j)
Next j
Next i
'traitement des lignes d'ingrédients des recettes et familles
nlig = 2
For i = 3 To UBound(base)
' une nouvelle famille ->
' on la stocke dans la variable Famille
If base(i, 1) <> "" Then Famille = base(i, 1)
' une nouvelle recette ->
' on incrémente la ligne du tableau res
' on inscrit dans la première colonne de res , la famille
' on inscrit dans la seconde colonne de res , la recette
If base(i, 2) <> "" Then
nlig = nlig + 1
res(nlig, 1) = Famille
res(nlig, 2) = base(i, 2)
End If
' pour l'ingrédient de base en cours,
' on boucle sur les colonnes des allergènes
For j = 4 To UBound(base, 2)
' si l'élément de base n'est pas vide
If Len(Trim(base(i, j))) > 0 Then
' on regarde si le résultat est déjà égal à "oui"
' si vrai on ne fait rien car l'allergène de la colonne
' a déjà été indentifié comme étant présent pour un précédent ingrédient
' si faux, on écrase la valeur de res(i,j) par la valeur de base(i,j)
' autrement dit, si res(i,j) est vide ou égal à "trace" (<> "oui")
' on écrase cette valeur par la valeur de base(i,j) qui est soit "oui"
' soit "trace"
' ou encore, si res(i,j) est déjà égal à "oui", on conserve cette valeur
If res(nlig, j) <> "oui" Then res(nlig, j) = base(i, j)
End If
Next j
Next i
' écriture du tableau res sur la feuille "Tab"
.Range("a1").Resize(UBound(res, 1), UBound(res, 2)) = res
' formatage du résultat
.Range("c1").CurrentRegion.Borders.LineStyle = xlContinuous
.Range("c1").CurrentRegion.VerticalAlignment = xlCenter
.Range("c1").CurrentRegion.HorizontalAlignment = xlCenter
.Range("c1").CurrentRegion.WrapText = True
.Range("c1").CurrentRegion.EntireColumn.ColumnWidth = 12
' mise en couleur : "oui" = rouge, "trace" = orange
For i = 3 To nlig
' coul va stocker le bilan de la ligne i
Coul = ""
' boucle sur les allergènes de la ligne
For j = 4 To UBound(res, 2)
Select Case res(i, j)
Case "oui"
' c'est un allergène, mise en couleur rouge de la cellule
.Cells(i, j).Interior.Color = RGB(255, 64, 28)
Coul = "oui"
' colonne C de la ligne, inscription de oui
Cells(i, 3) = Coul
' mise en couleur de la colonne C de la ligne
.Cells(i, 3).Interior.Color = RGB(255, 40, 20)
Case "trace"
' seulement une trace, mise en couleur orange de la cellule
.Cells(i, j).Interior.Color = RGB(255, 219, 0)
' sauf si le bilan de la ligne (coul) est déjà égal à oui
If Coul <> "oui" Then
Coul = "trace"
' colonne C de la ligne, inscription de trace
Cells(i, 3) = Coul
' mise en couleur de la colonne C de la ligne
.Cells(i, 3).Interior.Color = RGB(255, 167, 0)
End If
End Select
Next j
' fin de parcours des colonnes pour la ligne i
If Coul = "" Then
' coul est vide -> la recette nhje comporte ni oui ni trace
' mise en couleur de la colonne C de la ligne
.Cells(i, 3).Interior.Color = RGB(0, 255, 160)
' colonne C de la ligne, inscription de ok
.Cells(i, 3) = "ok"
End If
Next i
.Cells(2, "c") = "BILAN"
' filtage automatique
.Range(.Cells(2, "a"), .Cells(2, UBound(res, 2))).AutoFilter
End With
End Sub
