This is not very general purpose, but it works with your sample data
Option Explicit
Sub FormatData()
Dim wsIn As Worksheet, wsOut As Worksheet
Dim r As Long, c As Long
Dim rData As Range
Set wsIn = Worksheets("Before")
Set wsOut = Worksheets("After")
'copy input cells to output
wsIn.Cells(1, 1).CurrentRegion.Copy wsOut.Cells(1, 1)
'reference output cells
Set rData = wsOut.Cells(1, 1).CurrentRegion
'down the rows, starting at 2 until the end
For r = 2 To rData.Rows.Count
'accross the columns, starting at 4 untile the end
For c = 4 To rData.Columns.Count
'if the c-th cell in the r-th is blank, get the non-blank one to the right and put it there
' clear it afterwards
If Len(rData.Cells(r, c).Value) = 0 Then
rData.Cells(r, c).Value = rData.Cells(r, c).End(xlToRight).Value
rData.Cells(r, c).End(xlToRight).ClearContents
End If
Next c
Next r
'delete columns that only have the headers left
Set rData = wsOut.Cells(1, 1).CurrentRegion
Do While Application.WorksheetFunction.CountA(rData.Columns(rData.Columns.Count)) = 1
rData.Columns(rData.Columns.Count).EntireColumn.Delete
Set rData = wsOut.Cells(1, 1).CurrentRegion
Loop
End Sub