Ton tableau intermédiaire sera instantané, tout est transféré dans un array appelé result
Option Explicit
Sub Creation_Tableau()
Dim tbl As ListObject
Set tbl = Sheets("Tableau intermédiaire").ListObjects(1)
If Not tbl.DataBodyRange Is Nothing Then tbl.DataBodyRange.Delete
Dim result(), n As Long, i, j, k
n = 0
With Sheets("input").ListObjects(1)
For i = 1 To .ListRows.Count
n = n + 1
ReDim Preserve result(1 To 7, 1 To n)
For j = 1 To 5
result(j, n) = .DataBodyRange(i, j)
Next
j = 6
result(6, n) = .DataBodyRange(0, j)
result(7, n) = .DataBodyRange(i, j)
For j = 7 To 16
n = n + 1
ReDim Preserve result(1 To 7, 1 To n)
For k = 1 To 5
result(k, n) = result(k, n - 1)
Next
result(6, n) = .DataBodyRange(0, j)
result(7, n) = .DataBodyRange(i, j)
Next
Next
End With
Sheets("Tableau intermédiaire").Cells(2, 1).Resize(UBound(result, 2), UBound(result)) = Application.Transpose(result)
End Sub