See next code
Of course make a copy of the sheet
Sub PrepareData()
Dim WkTbl1(), WkTbl2()
Dim WkRg As Range
Dim I As Long, J As Long, K As Long
WkTbl1 = Range("A1").CurrentRegion.Offset(1, 0)
ReDim WkTbl2(1 To 2 * UBound(WkTbl1, 1), 1 To 4)
K = 1: I = 1
Do
For J = 2 To 4
WkTbl2(K, J) = WkTbl1(I, J)
WkTbl2(K + 1, J) = WkTbl1(I, J)
Next J
WkTbl2(K, 1) = WkTbl1(I, 1)
WkTbl2(K + 1, 1) = WkTbl1(I + 1, 1)
I = I + 1
K = K + 2
Loop While (I <= UBound(WkTbl1, 1) - 1)
For J = 2 To 4
WkTbl2(K - 1, J) = Empty
Next J
Range("A2").Resize(UBound(WkTbl2, 1), 4) = WkTbl2
End Sub
Bookmarks