```
Option Explicit
Sub CompactData()
Dim FirstCol As Long
Dim LastCol As Long
Dim row As Long
Dim col As Long
Dim NextCol As Long
Dim x As Long
FirstCol = 2
LastCol = Cells(1, Cells.Columns.Count).End(xlToLeft).Column
row = 2
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
With Sheets("Sheet1")
Do While Not IsEmpty(.Cells(row, 1))
For col = 1 To LastCol - 1
If IsEmpty(.Cells(row, (FirstCol - 1) + col)) Then
NextCol = 1
Do While IsEmpty(.Cells(row, (FirstCol - 1) + col + NextCol)) And (col + NextCol) < LastCol
NextCol = NextCol + 1
Loop
x = col
Do
.Cells(row, (FirstCol - 1) + x) = .Cells(row, (FirstCol - 1) + x + NextCol)
.Cells(row, (FirstCol - 1) + x + NextCol).ClearContents
x = x + 1
Loop While x + NextCol <= LastCol
End If
Next col
row = row + 1
Loop
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
```