"Chainer" 2 lignes en une seule selon plusieurs critères

Sub Rassembler()
Dim plage As Variant, tablo()
Application.ScreenUpdating = False
Set plage = [A5].CurrentRegion.Offset(1)
[22:65536].Delete xlUp 'RAZ
plage.Copy [A22] 'où l'on veut, éventuellement dans une autre feuille...
Set plage = [A22].Resize(plage.Rows.Count, plage.Columns.Count)
plage.Columns(6).Insert xlToRight 'une colonne de plus
ReDim tablo(1 To plage.Rows.Count - 1, 1 To plage.Columns.Count)
plage = plage 'matrice, plus rapide
For i = 1 To UBound(tablo)
  tablo(i, 1) = plage(i, 1)
  tablo(i, 2) = plage(i, 2)
  tablo(i, 3 - 2 * (plage(i, 4) = "Fin")) = plage(i, 3)
  tablo(i, 4 - 2 * (plage(i, 4) = "Fin")) = Format(plage(i, 7), "hh:mm")
  tablo(i, 7) = plage(i, 5)
  If plage(i, 2) = plage(i + 1, 2) Then
    tablo(i, 5) = plage(i + 1, 3)
    tablo(i, 6) = Format(plage(i + 1, 7), "hh:mm")
    i = i + 1
  End If
Next
'---restitution---
With [A22].Resize(UBound(tablo), 7)
  .Value = tablo
  On Error Resume Next
  .Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub

Sub Rassembler()
Dim plage As Variant, tablo()
plage = [A5].CurrentRegion.Offset(1) 'matrice, plus rapide
ReDim tablo(1 To UBound(plage), 1 To 7)
For i = 1 To UBound(tablo) - 1
  tablo(i, 1) = plage(i, 1)
  tablo(i, 2) = plage(i, 2)
  tablo(i, 3 - 2 * (plage(i, 4) = "Fin")) = plage(i, 3)
  tablo(i, 4 - 2 * (plage(i, 4) = "Fin")) = Format(plage(i, 6), "hh:mm")
  tablo(i, 7) = plage(i, 5)
  If plage(i, 2) = plage(i + 1, 2) Then
    tablo(i, 5) = plage(i + 1, 3)
    tablo(i, 6) = Format(plage(i + 1, 6), "hh:mm")
    i = i + 1
  End If
Next
'---restitution en [A22] (mais on peut le faire dans une autre feuille)---
Application.ScreenUpdating = False
[22:65536].Delete 'RAZ
Set plage = [A22].Resize(UBound(plage), 7)
[A6].Resize(plage.Rows.Count).Copy plage 'pour les couleurs
plage.Columns("C:G").HorizontalAlignment = xlCenter 'centrage (facultatif)
plage.Value = tablo 'restitution des valeurs
On Error Resume Next
plage.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

'---planning---
With Sheets("planche")
  .[2:65536].Clear 'RAZ
  plage.Columns(1).Copy .[A2]
  For i = 1 To plage.Rows.Count
    col1 = Application.Match(ref.Offset(i, 3) + 1 / 86400, .[1:1])
    If IsNumeric(col1) Then .Cells(i + 1, col1) = ref.Offset(i, 2)
    col2 = Application.Match(ref.Offset(i, 5) + 1 / 86400, .[1:1])
    .Cells(i + 1, col2) = ref.Offset(i, 4)
    If IsError(col1) Then col1 = col2
    .Range(.Cells(i + 1, col1), .Cells(i + 1, col2)).Interior.Color _
      = .Cells(i + 1, 1).Interior.Color
  Next
  .[B:CT].EntireColumn.AutoFit 'ajuste les largeurs des colonnes
  .Activate 'facultatif
End With