Private Sub Worksheet_Activate()
Dim d As Object, w As Worksheet, c As Range, a, b, t(), i&
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
On Error Resume Next 'si aucune SpecialCell
For Each w In Worksheets
If w.Name <> Me.Name Then
For Each c In w.Columns(2).SpecialCells(xlCellTypeConstants)
If c <> "Ingrédients" And c <> "Total" And IsNumeric(c(1, 2)) Then d(c.Value) = d(c.Value) + CDbl(c(1, 2))
Next c
End If
Next w
'---transposition---
a = d.keys: b = d.items
ReDim t(UBound(a), 1) 'base 0
For i = 0 To UBound(a)
t(i, 0) = a(i): t(i, 1) = b(i)
Next i
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Range("B3:C" & Rows.Count).Delete xlUp 'RAZ
[B3].Resize(i, 2) = t
[B3].Resize(i, 2).Sort [B3], xlAscending, Header:=xlNo 'tri alphabétique sur la colonne B
[B3:C3].Offset(i) = Array("Total", "=SUM(" & [C3].Resize(i).Address(0, 0) & ")")
[B3:C3].Offset(i).Font.Bold = True 'gras
[B3:C3].Offset(i).Font.Color = vbRed 'rouge
[B3].Resize(i + 1, 2).Borders.Weight = xlThin 'bordures
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub