Private Sub Worksheet_Activate()
Dim deb As Range, ncol%, base, d As Object, i&, n&, p&, j%
Set deb = [A1] '1ère cellule, à adapter
ncol = 6 'nombre de colonnes du tableau, à adapter
base = Feuil1.UsedRange.Resize(, ncol) 'tableau, CodeName de la feuille
'---liste des noms sans doublon---
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(base)
If base(i, 1) <> "" And Not d.exists(base(i, 1)) Then
n = n + 1
d(base(i, 1)) = n 'élimine les doublons et mémorise n
End If
Next i
'---remplissage du tableau---
If n Then
ReDim t(1 To n, 1 To ncol - 1) 'tableau base 1
For i = 2 To UBound(base)
If base(i, 1) <> "" Then
p = d(base(i, 1))
For j = 2 To ncol
If base(i, j) <> "" Then t(p, j - 1) = t(p, j - 1) + 1
Next j
End If
Next i
Application.ScreenUpdating = False
deb(2).Resize(n) = Application.Transpose(d.keys) 'titres colonne A
deb(2, 2).Resize(n, ncol - 1) = t 'restitution dans la feuille
deb.Resize(n + 1, ncol).Sort deb, Header:=xlYes 'tri sur les noms
deb.Resize(n + 1, ncol).Borders.Weight = xlThin 'bordures
End If
deb.Resize(, ncol) = Application.Index(base, 1, 0) 'titres ligne 1
Range(deb(n + 2), Rows(Rows.Count)).Delete 'RAZ en dessous
End Sub