Option Explicit
Sub TranchesH()
Dim TH(), TE(), LE&, TS(), LS&, Q As Integer, DHDéb As Date, DHFin As Date, Jour As Integer
TH = Array(35 / 144, 5 / 9, 125 / 144)
TE = ActiveSheet.[A2].Resize(ActiveSheet.[A1000000].End(xlUp).Row - 1, 2).Value
ReDim TS(1 To 5000, 1 To 3)
For LE = 1 To UBound(TE, 1)
DHDéb = TE(LE, 2)
DHFin = DHDéb + TE(LE, 1) / 24
For Q = 0 To 1
If TH(Q) > DHDéb - Int(DHDéb) Then Exit For
Next Q
Jour = 0
Do: LS = LS + 1
TS(LS, 2) = DHDéb
DHDéb = Int(DHDéb) + TH(Q) + Jour
If DHDéb >= DHFin Then Exit Do
TS(LS, 3) = DHDéb
TS(LS, 1) = CDbl((TS(LS, 3) - TS(LS, 2)) * 24)
If TS(LS, 1) = 0 Then LS = LS - 1
Q = (Q + 1) Mod 3: Jour = -(Q = 0)
Loop
TS(LS, 3) = DHFin
TS(LS, 1) = CDbl((TS(LS, 3) - TS(LS, 2)) * 24)
Next LE
ActiveSheet.[E2].Resize(LS, 3).Value = TS
End Sub