Private Sub Worksheet_Activate()
Dim An, d As Object, tablo, i&, j%, x$, a, b, resu(), n&
An = [E1] 'cellule à adapter
If LCase(An) = "toutes" Then An = "####" '4 chiffres
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = Sheets("FORMATEUR").[B1].CurrentRegion.Resize(, 6)
For i = 2 To UBound(tablo)
If LCase(tablo(i, 5)) = "validé" Then 'compare en minuscules
If tablo(i, 6) Like An Then
For j = 2 To 3
x = tablo(i, j)
If x <> "" Then d(x) = d(x) + Val(tablo(i, 4))
Next j
End If
End If
Next i
'---transposition---
If d.Count Then
a = d.keys: b = d.items
ReDim resu(UBound(a), 1) 'base 0
For n = 0 To UBound(a)
resu(n, 0) = a(n)
resu(n, 1) = b(n)
Next n
End If
'---restitution---
Application.EnableEvents = False 'désactive les évènements
With ListObjects(1).Range.Resize(, 2) 'tableau structuré
.AutoFilter: .AutoFilter 'si le tableau est filtré
With .Rows(2)
If n Then
.Resize(n) = resu
.Resize(n).Sort .Columns(2), xlDescending, Header:=xlYes 'tri décroissant
End If
.Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
End With
On Error Resume Next 'si aucune SpecialCell
.SpecialCells(xlCellTypeBlanks).Delete xlUp 'supprime les lignes vides s'il y en a
End With
Application.EnableEvents = True 'réactive les évènements
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Worksheet_Activate 'lance la macro
End Sub