XL 2013 Comment réaliser par VBA un récapitulatif avec somme des valeurs issues de plusieurs feuilles de calculs

Private Sub Worksheet_Activate()
Dim d As Object, w As Worksheet, colnom As Variant, colmontant As Variant, tablo, i&
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each w In Worksheets
    If LCase(Left(w.Name, 1)) = "s" Then 'le nom doit commencer par "s"
        colnom = Application.Match("nom*", w.Rows(1), 0)
        colmontant = Application.Match("montant*", w.Rows(1), 0)
        If IsNumeric(colnom) And IsNumeric(colmontant) Then
            With w.Range("A1", w.UsedRange)
                tablo = .Value 'matrice, plus rapide
                For i = 1 To UBound(tablo)
                    If tablo(i, colnom) <> "" And IsNumeric(tablo(i, colmontant)) Then _
                        d(tablo(i, colnom)) = d(tablo(i, colnom)) + tablo(i, colmontant)
                Next i
            End With
        End If
    End If
Next w
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination, à adapter
    If d.Count Then
        .Cells(1, 2).Resize(d.Count) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
        .Cells(1, 3).Resize(d.Count) = Application.Transpose(d.items)
        .Cells(1, 2).Resize(d.Count, 2).Sort .Cells(1, 2), xlAscending, Header:=xlNo 'tri
        .Cells(1) = 1: .Resize(d.Count).DataSeries 'numérotation
    End If
    .Offset(d.Count).Resize(Rows.Count - d.Count - .Row + 1, 3).ClearContents 'RAZ en dessous
End With
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub