Private Sub Worksheet_Activate()
Dim CritereFeuille, d As Object, w As Worksheet, tablo, i&, x$
CritereFeuille = LCase([C1]) 'pour ignorer la casse, à adapter
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each w In Worksheets
If InStr(LCase(w.Name), CritereFeuille) Then
tablo = w.UsedRange.Resize(, 2) 'matrice, plus rapide
For i = 2 To UBound(tablo)
x = tablo(i, 1)
If x <> "" Then d(x) = d(x) + tablo(i, 2)
Next
End If
Next
'---restitution---
Application.EnableEvents = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [B3] 'à adapter
If d.Count Then
.Resize(d.Count) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
.Cells(1, 2).Resize(d.Count) = Application.Transpose(d.items)
.Resize(d.Count, 2).Borders.Weight = xlHairline
End If
.Offset(d.Count).Resize(Rows.Count - d.Count - .Row + 1, 2).Delete xlUp 'RAZ dessous
End With
With UsedRange: End With 'actualise la barre de défilement verticale
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Worksheet_Activate 'lance la macro
End Sub