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