Bonsoir James007, Star-Lord
C'est ce résultat là que tu souhaites obtenir :
Un peu lent à cause du "ReDim Preserve"
Option Explicit
Sub test()
Dim a, e, i As Long, ii As Long, iii As Long, n As Long
Dim dateMin As Long, dateMax As Long, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
With Sheets("Ronde").Range("a1").CurrentRegion
a = .Value2
dateMin = a(2, 1): dateMax = a(UBound(a), 1)
For i = dateMin To dateMax
dico(i) = Empty
Next
For i = 2 To UBound(a, 1)
If IsEmpty(dico(a(i, 1))) Then
ReDim w(1 To UBound(a, 2), 1 To 1)
Else
w = dico(a(i, 1))
ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
End If
For ii = 1 To UBound(a, 2)
w(ii, UBound(w, 2)) = a(i, ii)
Next
dico(a(i, 1)) = w
Next
For i = 0 To dico.Count - 1
If IsEmpty(dico.Items()(i)) Then
ReDim w(1 To UBound(dico.Items()(i - 1), 1), 1 To UBound(dico.Items()(i - 1), 2))
For ii = 1 To UBound(dico.Items()(i - 1), 2)
w(1, ii) = dico.keys()(i)
Next
For ii = 2 To UBound(dico.Items()(i - 1), 1)
For iii = 1 To UBound(dico.Items()(i - 1), 2)
w(ii, iii) = dico.Items()(i - 1)(ii, iii)
Next
Next
dico.Item(dico.keys()(i)) = w
End If
Next
With .Offset(, .Columns.Count + 3)
.CurrentRegion.Clear
.Resize(1) = Array("Date", "N° Véhicule", "N° Place", "Nom de l'agent")
n = 2
For Each e In dico.keys
With .Cells(n, 1).Resize(UBound(dico(e), 2), UBound(dico(e), 1))
.Value = Application.Transpose(dico(e))
.BorderAround Weight:=xlThin
End With
n = n + UBound(dico(e), 2)
Next
With .CurrentRegion
.Rows(1).Interior.ColorIndex = 43
.HorizontalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.VerticalAlignment = xlCenter
.Font.Name = "Calibri"
.Font.Size = 10
.Columns(1).NumberFormat = "m/d/yyyy"
.Columns.AutoFit
End With
End With
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Sub
klin89