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
Sub Demo1()
Dim Rg As Range
With Application
.ScreenUpdating = False
For Each Rg In Range("A2", [A1].End(xlDown))
Set Rg = Range(Rg, Rg(1, Columns.Count).End(xlToLeft))
If .CountBlank(Rg) Then Rg.SpecialCells(4).Delete xlToLeft
Next
.ScreenUpdating = True
End With
End Sub
Have a try with this macro on a test file. It should do what you are looking for otherwise you can use it as a starting point and adapt it to your needs.Code: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