Private Sub Worksheet_Activate()
Dim dest As Range, col1%, col2%, resu(), w As Worksheet, tablo, i&, cle$, Collec As New Collection, CollecN As New Collection, n&, lig&
Set dest = [B3] 'cellule de destination, à adapter
col1 = 1 'numéro de colonne des noms
col2 = 2 'numéro de colonne des valeurs
ReDim resu(1 To Rows.Count, 1 To 2)
For Each w In Worksheets
If w.Name <> Me.Name Then
tablo = w.UsedRange.Resize(, IIf(col1 < col2, col2, col1)) 'matrice, plus rapide
For i = 1 To UBound(tablo)
If IsNumeric(CStr(tablo(i, col2))) Then
On Error Resume Next
cle = tablo(i, col1)
Collec.Add cle, cle
If Err = 0 Then
n = n + 1
CollecN.Add n, cle 'mémorise la ligne
resu(n, 1) = cle
resu(n, 2) = tablo(i, col2)
Else
lig = CollecN(cle)
resu(lig, 2) = resu(lig, 2) + tablo(i, col2)
End If
End If
Next
End If
Next
On Error GoTo 0
'---restitution---
If n Then
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
dest.Resize(n, 2) = resu
dest.Resize(n, 2).Sort dest, xlAscending, Header:=xlNo 'tri sur les noms
End If
dest.Offset(n).Resize(Rows.Count - n - dest.Row + 1, 2).ClearContents 'RAZ en dessous
dest.EntireColumn.Resize(, 2).AutoFit 'ajustement largeurs
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub