Sub mrshkei()
Dim arr, arr2, i As Long, n As Long, lr As Long, k As Long, k2 As Long, rng As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A1:E" & lr)
ReDim arr2(1 To lr, 1 To 3 * 40 + 1): k = 2
arr2(1, 1) = arr(1, 1)
For i = 2 To (3 * 40 + 1) Step 3
    arr2(1, i) = arr(1, 2)
    arr2(1, i + 1) = arr(1, 3)
    arr2(1, i + 2) = arr(1, 4)
Next i
For i = LBound(arr) + 1 To UBound(arr) Step 40
k2 = 2
arr2(k, 1) = arr(i, 1)

For n = 0 To 8

Sub mrshkei()
Dim arr, arr2, i As Long, n As Long, lr As Long, k As Long, k2 As Long, rng As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A1:E" & lr)
ReDim arr2(1 To lr, 1 To 3 * 40 + 1): k = 2
arr2(1, 1) = arr(1, 1)
For i = 2 To (3 * 40 + 1) Step 3
    arr2(1, i) = arr(1, 2)
    arr2(1, i + 1) = arr(1, 3)
    arr2(1, i + 2) = arr(1, 4)
Next i
For i = LBound(arr) + 1 To UBound(arr) Step 40
k2 = 2
arr2(k, 1) = arr(i, 1)
    For n = 0 To 8
        arr2(k, k2) = arr(i + n, 2)
        arr2(k, k2 + 1) = arr(i + n, 3)
        arr2(k, k2 + 2) = arr(i + n, 4)
        k2 = k2 + 3
    Next n
    k = k + 1
Next i
Set rng = Application.InputBox("Âûáåðèòå îäíó ÿ÷åéêó ñ êîòîðîé íà÷íåòñÿ âûâîä ðåçóëüòàòà", Type:=8)
rng.Resize(UBound(arr2), UBound(arr2, 2) - LBound(arr2) + 1) = arr2
End Sub