Option Explicit
Sub test()
Dim dico As Object, a, w(), i As Long, col As Byte
Dim e, v, n As Long, t As Long
Set dico = CreateObject("Scripting.Dictionary")
a = Sheets("Planning").Range("a4").CurrentRegion.Value
For col = 2 To UBound(a, 2)
Set dico(a(1, col)) = _
CreateObject("Scripting.Dictionary")
dico(a(1, col)).CompareMode = 1
For i = 2 To UBound(a, 1)
If Not dico(a(1, col)).exists(a(i, col)) Then
ReDim w(1 To 2, 1 To 1)
w(1, 1) = a(i, col)
Else
w = dico(a(1, col))(a(i, col))
ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
End If
w(2, UBound(w, 2)) = a(i, 1)
dico(a(1, col))(a(i, col)) = w
Next
Next
Application.ScreenUpdating = False
With Sheets("Rapport")
.Cells.Clear
With .Range("a1")
For Each e In dico
With .Offset(n, t).Resize(1, 2)
.Value = Array(e, "date")
.Font.Bold = True
.Interior.ColorIndex = 43
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
End With
n = 1
For Each v In dico(e)
With .Offset(n, t).Resize(UBound(dico(e)(v), 2), UBound(dico(e)(v), 1))
.FormulaLocal = Application.Transpose(dico(e)(v))
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Cells(1)
.Interior.ColorIndex = 36
.BorderAround Weight:=xlThin
End With
End With
n = n + UBound(dico(e)(v), 2)
Next
n = 0: t = t + 3
Next
End With
With .UsedRange.Cells
.Font.Size = 10
.Font.Name = "calibri"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Sub