Re-,
regarde le fichier joint, et clique sur le rectangle, dans l'onglet origine
le code :
Sub transpose()
Dim LesNoms As Object, Cel As Range
Dim Lig As Long, Col1 As Integer, Col2 As Integer
Set LesNoms = CreateObject("Scripting.Dictionary")
For Each Cel In Range("A2:A" & [A65000].End(xlUp).Row)
If Not LesNoms.Exists(Cel.Value) Then LesNoms.Add Cel.Value, Cel.Value
Next Cel
With Sheets("cible")
.Range("A2:CZ100").ClearContents
.Range("A2:A" & LesNoms.Count + 1).Value = Application.transpose(LesNoms.items)
For Each Cel In Range("A2:A" & [A65000].End(xlUp).Row)
Lig = Application.Match(Cel, .Range("A1:A" & .[A65000].End(xlUp).Row), 0)
Col1 = CDate(Format(Cel.Offset(0, 2), "dd/mm/yyyy")) - .[B1] + 2
Col2 = CDate(Format(Cel.Offset(0, 3), "dd/mm/yyyy")) - .[B1] + 2
If Col1 = Col2 Then
.Cells(Lig, Col1).Value = "Début : " & Format(Cel.Offset(0, 2), "hh:mm") _
& " - Fin : " & Format(Cel.Offset(0, 3), "hh:mm")
Else
.Cells(Lig, Col1).Value = "Début : " & Format(Cel.Offset(0, 2), "hh:mm")
If Col2 - Col1 > 1 Then _
.Cells(Lig, Col1).Offset(0, 1).Resize(1, Col2 - Col1 - 1).Value = 1
.Cells(Lig, Col2).Value = "Fin : " & Format(Cel.Offset(0, 3), "hh:mm")
End If
Next Cel
.Cells.EntireColumn.AutoFit
End With
End Sub
le fichier :
https://www.excel-pratique.com/~files/doc/Copie_de_Fh7JGetvoila.zip