transformation d'une ligne en plusieurs lignes "par tranche de 5"

Sub toto()
Dim i&, j&, k&, l&, m&, u1&, u2&, d(), w()
  d = Feuil1.[A4].CurrentRegion.Value
  u1 = UBound(d, 1)
  u2 = UBound(d, 2)
  For i = 2 To u1: For j = 5 To u2 Step 5
    If Not IsEmpty(d(i, j)) Then k = k + 1
  Next j, i
  k = u1 + k + 1
  ReDim w(1 To k, 1 To 9)
  For i = 1 To 9: w(1, i) = d(1, i): Next
  l = 1
  For i = 2 To u1
    For j = 5 To u2 Step 5
      If Not IsEmpty(d(i, j)) Then
        l = l + 1
        For m = 1 To 4: w(l, m) = d(i, m): Next
        For m = j To j + 4: w(l, m - j + 5) = d(i, m): Next
      End If
    Next
    l = l + 1: w(l, 1) = " "
  Next
  With Feuil2.[A1]
    .CurrentRegion.ClearContents
    .Resize(k, 9).Value = w
    .Parent.Activate
  End With
End Sub

Ici code VBA

Sub toto()
Dim i&, j&, k&, l&, m&, u1&, u2&, d(), w()
Const ne% = 9, nc% = 3
  d = Feuil1.[A4].CurrentRegion.Value
  u1 = UBound(d, 1)
  u2 = UBound(d, 2)
  u2 = u2 - (nc - (u2 - ne) Mod nc) * ((u2 - ne) Mod nc <> 0)
  ReDim Preserve d(1 To u1, 1 To u2)
  For i = 2 To u1: For j = ne + 1 To u2 Step nc
    If Not IsEmpty(d(i, j)) Then k = k + 1
  Next j, i
  k = u1 + k + 1
  ReDim w(1 To k, 1 To ne + nc)
  For i = 1 To ne + nc: w(1, i) = d(1, i): Next
  l = 1
  For i = 2 To u1
    For j = ne + 1 To u2 Step nc
      If Not IsEmpty(d(i, j)) Then
        l = l + 1
        For m = 1 To ne: w(l, m) = d(i, m): Next
        For m = j To j + nc - 1: w(l, m - j + ne + 1) = d(i, m): Next
      End If
    Next
  Next
  With Feuil2.[A1]
    .CurrentRegion.ClearContents
    .Resize(k, ne + nc).Value = w
    .Parent.Activate
  End With
End Sub