• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Data Consolidation

Ram Chandran

New Member
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
 

Attachments

  • Sample.xlsx
    22.3 KB · Views: 8
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
 
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 !​
 
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

Hi Rollis,

thanks for your code.
 
Back
Top