You are using an out of date browser. It may not display this or other websites correctly.

You should upgrade or use an alternative browser.

You should upgrade or use an alternative browser.

- Thread starter Ram Chandran
- Start date

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
```

Hi, according to the attachment an Excel basics VBA demonstration for starters :

Code:

```
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
```

Do you like it ? So thanks to click on bottom right *Like* !

Hi Marc,

Thanks for your kind reply. Its work fine.

Thanks for your kind reply. Its work fine.

Last edited by a moderator:

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`

Hi Rollis,

thanks for your code.