Sub Transposer()
Dim t, ub&, h&, tp(), i&, j&, n, lig, col
Sheets("vertical").Activate
t = Range("A2:D" & Range("D" & Rows.Count).End(xlUp).Row)
ub = UBound(t)
h = 3 * Application.CountA(Application.Index(t, 0, 1)) - 1
ReDim tp(h, 0) 'base 0
For i = 1 To ub
If t(i, 1) <> "" Then
tp(lig, 0) = t(i, 1)
j = i
While j = i Or t(j, 1) = ""
n = j - i + 1
If n > col Then col = n
ReDim Preserve tp(h, col)
tp(lig, n) = t(j, 4)
tp(lig + 1, n) = IIf(t(j, 2) & t(j, 3) = "", "", t(j, 2) + t(j, 3))
If j = ub Then GoTo 1
j = j + 1
Wend
i = j - 1
lig = lig + 3
End If
Next
'---restitution et bordures---
1 With Sheets("horizontal") 'feuille à adapter
.Cells.ClearContents
.[B3].Resize(h + 1, col + 1) = tp
.Cells.Borders.LineStyle = xlNone
With .Cells.SpecialCells(xlCellTypeConstants, 1)
Union(.Cells, .Offset(1)).Borders.Weight = xlThin
End With
.Activate
End With
End Sub