Private Sub Worksheet_Activate()
Dim d As Object, titre As Range, ncol%, resu(), w As Worksheet, i&, n&, nn&, j%, compte&
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Set titre = [A1].CurrentRegion.Rows(1).Cells
ncol = titre.Count
ReDim resu(1 To 1000, 1 To ncol) 'hauteur 1000 lignes maximum, à adapter
For Each w In Worksheets
If w.Name Like "S#*" Then
If w.FilterMode Then w.ShowAllData 'si la feuille est filtrée
For i = 6 To w.Range("A" & w.Rows.Count).End(xlUp).Row
With w.Cells(i, 1)
If .Value <> "" Then
If Not d.exists(.Value) Then
n = n + 1
d(.Value) = n 'mémorise le n° de ligne
resu(n, 1) = .Value
End If
nn = d(.Value)
For j = 2 To ncol
compte = Application.CountIf(.EntireRow, titre(j)) 'NB.SI
If compte Then resu(nn, j) = resu(nn, j) + compte
Next j
End If
End With
Next i
End If
Next w
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2]
If n Then
.Resize(n, ncol) = resu
.Resize(n, ncol).Sort .Cells(1), xlAscending, Header:=xlYes 'tri alphabétique
.Resize(n, ncol).Borders.Weight = xlThin 'bordures
End If
.Offset(n).Resize(Rows.Count - n - .Row + 1, ncol).Delete xlUp 'RAZ en dessous
End With
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub