Data Consolidation

[Ram Chandran]

Hi all,

I have attached the example sample.
Kindly help me to move a set of data from right side to left side only if blank cell.
Shown in arrows.

Thanks in advance

 

[rollis13]

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.

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

 

[Marc L]

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

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 !​

​

 

[Ram Chandran]

Hi Marc,

Thanks for your kind reply. Its work fine.

 

[Ram Chandran]

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.

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.