Private Sub Worksheet_Activate()
Dim tablo, nlig&, ncol%, dercol%, c As New Collection, cc As New Collection, j%, i&, n&, resu(), nn&, k%
tablo = Sheets("Feuil1").[A1].CurrentRegion 'matrice, plus rapide
nlig = UBound(tablo)
ncol = UBound(tablo, 2)
dercol = 46 'colonne AT, à adapter
'---liste des élémenrs sans doublon---
On Error Resume Next
For j = 1 To dercol Step 5 'colonnes A, F,...AT
For i = 2 To nlig
c.Add c.Count + 1, LCase(tablo(i, j)) 'mémorise le rang
cc.Add tablo(i, j), CStr(c.Count) 'récupère la clé avec la casse d'origine
Next i, j
On Error GoTo 0
n = c.Count
If n = 0 Then GoTo 1 'si le tableau est vide
'---tableau des résultats---
ReDim resu(1 To n, 1 To ncol)
For i = 1 To n
resu(i, 1) = cc(CStr(i))
Next i
For j = 1 To dercol Step 5 'colonnes A, F,...AT
For i = 2 To nlig
nn = c(LCase(tablo(i, j))) 'récupère le rang
resu(nn, j + 1) = resu(nn, j + 1) + tablo(i, j + 1)
resu(nn, j + 2) = resu(nn, j + 2) + tablo(i, j + 2)
resu(nn, j + 3) = resu(nn, j + 3) + tablo(i, j + 3)
resu(nn, j + 4) = resu(nn, j + 4) + tablo(i, j + 4)
If j = dercol Then 'dernière zone
For k = dercol + 5 To ncol
resu(nn, k) = resu(nn, k) + tablo(i, k)
Next k
End If
Next i, j
'---restitution---
1 Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de restitution
If n Then
.Resize(n, ncol) = resu
'.Resize(n, ncol).Sort .Cells, xlAscending, Header:=xlNo 'tri alphabétique facultatif
End If
.Cells(0, 1).Resize(, ncol) = Application.Index(tablo, 1, 0) 'copie les en-têtes
.Cells(0, 2).Resize(, ncol - 1).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete 'supprime les colonnes vides intermédiaires
.Offset(n).Resize(Rows.Count - n - .Row + 1, ncol).ClearContents 'RAZ en dessous
End With
Columns.AutoFit 'ajuste les largeurs
With UsedRange: End With 'actualise les barres de défilement
End Sub