Macro for Looping Transposition

Hi Miroslav,
try this

Sub ertert()
Dim x, y(), i&, j&, k&
x = Sheets("Sheet1").Range("A2").CurrentRegion.Value
ReDim y(1 To UBound(x) * (UBound(x, 2) - 3), 1 To 6)
For i = 2 To UBound(x) Step 4
    For j = 4 To UBound(x, 2)
        If IsNumeric(x(i, j)) Then
            k = k + 1
            y(k, 1) = Val(x(i, 1))
            y(k, 2) = x(1, j): y(k, 3) = x(i, j)
            y(k, 4) = x(i + 1, j): y(k, 5) = x(i + 2, j)
            y(k, 6) = x(i + 3, j)
        End If
    Next j
Next i
With Sheets("Sheet2").Range("A2").CurrentRegion.Offset(1)
    .ClearContents
    .Resize(k, 6).Value = y()
End With
End Sub