Option Explicit
Sub test()
Dim a, w(), i As Long, j As Long, n As Long, e, s
Dim dico As Object
a = Sheets("planning").Range("b4").CurrentRegion.Value
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
For i = 2 To UBound(a, 2)
If IsEmpty(a(1, i)) Then a(1, i) = a(1, i - 1)
If Not dico.exists(a(1, i)) Then
Set dico(a(1, i)) = _
CreateObject("Scripting.Dictionary")
dico(a(1, i)).CompareMode = 1
End If
dico(a(1, i))(a(2, i)) = Empty
For j = 3 To UBound(a, 1)
If a(j, i) <> "" Then
If IsEmpty(dico(a(1, i))(a(2, i))) Then
ReDim w(1 To 1)
Else
w = dico(a(1, i))(a(2, i))
ReDim Preserve w(1 To UBound(w) + 1)
End If
w(UBound(w)) = a(j, 1)
dico(a(1, i))(a(2, i)) = w
End If
Next
Next
'restitution et mise en forme
Application.ScreenUpdating = False
With Sheets("Feuil1").Cells(1)
.Parent.Cells.Clear
For Each e In dico.keys
With .Offset(n)
.FormulaLocal = e
.NumberFormat = "dddd dd mmmm yyyy"
With .Resize(, 6)
.HorizontalAlignment = xlCenterAcrossSelection
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 36
End With
End With
For Each s In dico(e).keys
n = n + 1
With .Offset(n, 2)
.Value = s
With .Resize(, 2)
.HorizontalAlignment = xlCenterAcrossSelection
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 44
End With
End With
n = n + 1
If Not IsEmpty(dico(e)(s)) Then
w = dico(e)(s)
With .Offset(n, 2).Resize(UBound(w))
.Value = Application.Transpose(dico(e)(s))
With .Resize(, 2)
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
End With
n = n + UBound(w)
End With
End If
Next
n = n + 1
Next
With .Parent.UsedRange
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.Columns.ColumnWidth = 11
End With
.Parent.Activate
End With
Application.ScreenUpdating = True
Set dico = Nothing
End Sub