Here is a simple loop that works bottom up in the sheet, shifts last line over 4 columns, copies line above down and then deletes the line above.
Sub TransposeData()
Dim WS As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
Set WS = Worksheets("Sheet1")
With WS
Set LastCell = .Cells(.Rows.Count, "A").End(xlUp)
LastCellRowNumber = LastCell.Row
End With
'Loop through column A bottom up
For i = LastCellRowNumber To 2 Step -1
'Shift current values over
Range("A" & i & ":D" & i).Insert Shift:=xlToRight
'Copy new values down
Range("A" & i & ":D" & i).Value = Range("A" & i - 1 & ":D" & i - 1).Value
'Delete row
Rows(i - 1).Delete Shift:=xlUp
Next i
End Sub
Before:
After: