Private Sub Worksheet_Activate()
Dim sh, Indice As New Collection, x, aux, i&
On Error Resume Next
For Each sh In ThisWorkbook.Worksheets
If LCase(Trim(sh.Name)) Like "fiche #*" Then
x = LCase(Application.Trim(sh.Range("a2"))): aux = Empty: aux = Indice(x)
If IsEmpty(aux) Then Indice.Add Array(x, 1), x Else aux(1) = aux(1) + 1: Indice.Remove x: Indice.Add aux, x
End If
Next sh
On Error GoTo 0
Worksheets("Synthèse").Range("b2:c" & Rows.Count).ClearContents
If Indice.Count < 1 Then Exit Sub
ReDim r(1 To Indice.Count, 1 To 2)
For i = 1 To Indice.Count: aux = Indice.Item(i): r(i, 1) = aux(0): r(i, 2) = aux(1): Next
Worksheets("Synthèse").Range("b2").Resize(Indice.Count, 2) = r
End Sub