Sub Extract()
Dim T, Feuille, dico, i As Long, DerL As Integer, Clé, T2, TmP, x As Integer
Set dico = CreateObject("Scripting.Dictionary")
Feuille = Array("1ere collecte", "2eme collecte", "3eme collecte", "4eme collecte", "5eme collecte")
For Each sh In Feuille
DerL = Worksheets(sh).Range("B" & Rows.Count).End(xlUp).Row
If DerL > 1 Then
T = Worksheets(sh).Range("B3:F" & DerL)
For i = LBound(T, 1) To UBound(T, 1)
Clé = T(i, 1) & "|" & T(i, 2) & "|" & T(i, 3) & "|" & T(i, 4) & "|" & T(i, 5)
dico(Clé) = dico(Clé) + 1
Next
End If
Next
ReDim T2(1 To dico.Count, 1 To UBound(T, 2) + 1)
For Each Clé In dico.keys
x = x + 1
TmP = Split(Clé, "|")
For i = LBound(TmP) To UBound(TmP)
T2(x, i + 1) = TmP(i)
Next
T2(x, UBound(TmP) + 2) = dico(Clé)
Next
Worksheets("Statistiques").Range("A2").Resize(UBound(T2, 1), UBound(T2, 2)) = T2
End Sub