Sub Dispatch_V2()
Dim T, i As Long, DerL As Long, Deb As Long, Skipper, Dico, TT(), Clé, NbL As Integer
Start = Timer
Application.ScreenUpdating = False
Set Dico = CreateObject("Scripting.Dictionary")
With Worksheets("Classement")
DerL = .Range("A" & Rows.Count).End(xlUp).Row
If .Range("F1") = DerL Then
MsgBox "Pas de nouvelles données à traiter"
Exit Sub
Else
Deb = .Range("F1") + 1
End If
T = .Range("A" & Deb & ":T" & DerL)
End With
For i = LBound(T, 1) To UBound(T, 1)
If IsNumeric(T(i, 2)) And T(i, 2) <> "" Then
Skipper = Split(T(i, 4), vbLf)(0) '
If Not Dico.exists(Skipper) Then
ReDim TT(1 To 1)
TT(1) = Application.Index(T, i)
Else
TT = Dico(Skipper)
ReDim Preserve TT(1 To UBound(TT) + 1)
TT(UBound(TT)) = Application.Index(T, i)
End If
Dico(Skipper) = TT
If UBound(TT) > NbL Then NbL = UBound(TT)
Erase TT
End If
Next
For Each Clé In Dico.keys
With Worksheets(Clé) '
.Range("A" & .Range("F" & Rows.Count).End(xlUp).Row + 1).Resize(UBound(Dico(Clé)), UBound(T, 2)) = Application.Transpose(Application.Transpose(Dico(Clé)))
End With
Next
Worksheets("Classement").Range("F1") = DerL
Application.ScreenUpdating = True
MsgBox Timer - Start
End Sub