Re loic.vazquez,
Restitution en Feuil1 préalablement créée
La feuille source reste en l'état initial ---> pas de cellule fusionnée
A tester :
Option Explicit
Sub test()
Dim a, w(), i As Long, j As Long, n As Long, lig As Long, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
With Sheets("Calendrier")
a = .Range("a5").CurrentRegion.Value
For i = 2 To UBound(a, 1)
If Not dico.exists(a(i, 1)) Then
Set dico(a(i, 1)) = CreateObject("Scripting.Dictionary")
dico(a(i, 1)).CompareMode = 1
End If
If Not dico(a(i, 1)).exists(a(i, 7)) Then
ReDim w(1 To UBound(a, 2), 1 To 1)
Else
w = dico(a(i, 1))(a(i, 7))
ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
End If
For j = 1 To UBound(w, 1)
w(j, UBound(w, 2)) = a(i, j)
Next
dico(a(i, 1))(a(i, 7)) = w
Next
End With
Application.ScreenUpdating = False
With Sheets("feuil1").Range("a1")
.CurrentRegion.Cells.Clear: n = 1
.Resize(1, UBound(a, 2)).Value = a
Application.DisplayAlerts = False
For i = 0 To dico.Count - 1
lig = n
For j = 0 To dico.items()(i).Count - 1
With .Offset(n).Resize(UBound(dico.items()(i).items()(j), 2), _
UBound(dico.items()(i).items()(j), 1))
.FormulaLocal = Application.Transpose(dico.items()(i).items()(j))
If UBound(dico.items()(i).items()(j), 2) > 1 Then
.Columns(7).Merge
End If
End With
n = n + UBound(dico.items()(i).items()(j), 2)
Next
If n - lig > 1 Then
With .Offset(lig).Resize(n - lig)
.Merge
.Resize(, 7).BorderAround Weight:=xlThin
End With
End If
' If n > lig + 1 Then
' .Range(.Cells(lig + 1, 1), .Cells(n, 1)).Merge
' End If
Next
Application.DisplayAlerts = True
With .CurrentRegion
.Columns("b:d").NumberFormat = "hh \h mm"
With .Font
.Name = "calibri": .Size = 10
End With
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.VerticalAlignment = xlCenter
With .Rows(1)
.HorizontalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 36
.Font.Size = 10
End With
.Columns.AutoFit
End With
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Sub
klin89