Private Sub Worksheet_Activate()
Dim t#, tablo, d As Object, i&, a, b, n&, c()
t = Timer
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
tablo = Sheets("DETAILS").[A1].CurrentRegion.Resize(, 4) 'matrice, plus rapide
With ListObjects(1) 'tableau Excel
.ShowTotals = False
If .ListRows.Count Then .DataBodyRange.Delete xlUp 'RAZ
'---liste concaténée sans doublons---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(tablo)
d(tablo(i, 2) & tablo(i, 4)) = tablo(i, 2)
Next i
If d.Count = 0 Then Exit Sub 'si le tableau est vide
'---comptage des items---
a = d.items
d.RemoveAll 'RAZ
For i = 0 To UBound(a)
d(a(i)) = d(a(i)) + 1
Next
a = d.keys: b = d.items: n = UBound(a)
'---transposition---
ReDim c(0 To n, 0 To 1)
For i = 0 To n
c(i, 0) = a(i): c(i, 1) = b(i)
Next
'---restitution---
With .Range.Rows(2).Resize(n + 1)
.Value = c
.Sort .Columns(1), xlAscending, Header:=xlYes
End With
.ShowTotals = True 'option "Ligne des totaux" cochée
End With
MsgBox "Tableau mis à jour en " & Format(Timer - t, "0.00 \s") 'facultatif bien sûr
End Sub