Microsoft 365 Transposer 1 ligne en plusieurs

Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("B4:F4")) Is Nothing Then
        Dim N%, i%
        [B6:F9].ClearContents
        N = 6
        For i = 3 To 6
            If Cells(4, i) <> "" Then
                Cells(N, "B") = [B4]
                Cells(N, i) = Cells(4, i)
                N = N + 1
            End If
        Next i
    End If
End Sub

Sub Premisses()
Dim dl&, i&, x&, xx
dl = Cells(Rows.Count, 1).End(xlUp).Row
For i = dl To 2 Step -1
x = Application.CountA(Cells(i, 1).Offset(, 1).Resize(, 4)) - 1
xx = Cells(i, 1)
Cells(i, 1).Resize(x, 5).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(i, 1).Resize(x) = xx
xx = ""
Next
End Sub