Solved

move columns

Posted on 2014-03-12
13
180 Views
Last Modified: 2014-03-13
Hello ;


I need assistance in moving columns using VBA with certain logic... from column B to Column G
move column to the left if column is empty.

Sample data and output attached
Sample-Data-Move-Columns---Sheet.csv
0
Comment
Question by:CalmSoul
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 8
  • 5
13 Comments
 
LVL 39

Expert Comment

by:nutsch
ID: 39924960
Try this code


Sub MoveColumns()
Dim lLoop As Long, rgBlanks As Range, lCount As Long

Dim lLastRow As Long, lRowLoop As Long

lLastRow = Cells(Rows.Count, 1).End(xlUp).Row

'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With


For lCount = 1 To 6
    For lLoop = 6 To 2 Step -1
         
         On Error Resume Next
         Set rgBlanks = Range(Cells(2, lLoop), Cells(lLastRow, lLoop)).SpecialCells(xlCellTypeBlanks)
         
        If Err = 0 Then
            rgBlanks.FormulaR1C1 = "=if(len(RC[1])=0,"""",rc[1])"
            Range(Cells(2, lLoop), Cells(lLastRow, lLoop)).Value = Range(Cells(2, lLoop), Cells(lLastRow, lLoop)).Value
            
            rgBlanks.Offset(, 1).ClearContents
        Else
            Err.Clear
        End If
    Next lLoop

Next lCount

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With


End Sub

Open in new window

0
 
LVL 39

Expert Comment

by:nutsch
ID: 39925020
Or a more elegant version:

Sub MoveColumns()
Dim lLoop As Long, rgBlanks As Range, lCount As Long, rgBlock As Range, bKeepMoving As Boolean

Dim lLastRow As Long, lRowLoop As Long

lLastRow = Cells(Rows.Count, 1).End(xlUp).Row

'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With


For lLoop = 2 To 6
     
    Do While Application.WorksheetFunction.CountA(Range(Cells(2, lLoop), Cells(lLastRow, lLoop))) <> Range(Cells(2, lLoop), Cells(lLastRow, lLoop)).Cells.Count
    
        bKeepMoving = False
    
        Set rgBlanks = Range(Cells(2, lLoop), Cells(lLastRow, lLoop)).SpecialCells(xlCellTypeBlanks)
         
        For Each rgBlock In rgBlanks.Areas
         
            If lLoop < 6 Then
                If Application.WorksheetFunction.CountA(rgBlock.Offset(0, 2).Resize(, 6 - lLoop)) > 0 Then bKeepMoving = True
            End If
         
            rgBlock.Offset(0, 1).Resize(, 6 - lLoop + 1).Cut rgBlock.Resize(, 6 - lLoop + 1)
         
        Next rgBlock
        
        If Not bKeepMoving Then Exit Do
    Loop
Next lLoop


With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With


End Sub

Open in new window

0
 
LVL 5

Author Comment

by:CalmSoul
ID: 39925189
nope this is not working
0
Online Training Solution

Drastically shorten your training time with WalkMe's advanced online training solution that Guides your trainees to action. Forget about retraining and skyrocket knowledge retention rates.

 
LVL 39

Expert Comment

by:nutsch
ID: 39925203
Can you expand your "not working" comment? Can you run the macro?

If I open your file, remove the output bottom half, copy the code in a module and execute the macro, it returns the OUTPUT format to a t.
0
 
LVL 5

Author Comment

by:CalmSoul
ID: 39925208
I ran it ... with 6 columns it works but I change the loop from 6 to 11 it didn't work... its limited to 2 to 6? only?
0
 
LVL 39

Expert Comment

by:nutsch
ID: 39925216
No offense, but if you spec a question with 6 columns, you'll get code for 6 columns...

Here's an update:

Sub MoveColumns()
Dim lLoop As Long, rgBlanks As Range, lCount As Long, rgBlock As Range, bKeepMoving As Boolean

Dim lLastRow As Long, lRowLoop As Long

lLastRow = Cells(Rows.Count, 1).End(xlUp).Row

'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

Const lStartColumn As Long = 2
Const lEndColumn As Long = 7


For lLoop = lStartColumn To lEndColumn
     
    Do While Application.WorksheetFunction.CountA(Range(Cells(2, lLoop), Cells(lLastRow, lLoop))) <> Range(Cells(2, lLoop), Cells(lLastRow, lLoop)).Cells.Count
    
        bKeepMoving = False
    
        Set rgBlanks = Range(Cells(2, lLoop), Cells(lLastRow, lLoop)).SpecialCells(xlCellTypeBlanks)
         
        For Each rgBlock In rgBlanks.Areas
         
            If lLoop < lEndColumn Then
                If Application.WorksheetFunction.CountA(rgBlock.Offset(0, 2).Resize(, lEndColumn - lLoop)) > 0 Then bKeepMoving = True
            End If
         
            rgBlock.Offset(0, 1).Resize(, lEndColumn - lLoop + 1).Cut rgBlock.Resize(, lEndColumn - lLoop + 1)
         
        Next rgBlock
        
        If Not bKeepMoving Then Exit Do
    Loop
Next lLoop


With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With


End Sub

Open in new window

0
 
LVL 39

Expert Comment

by:nutsch
ID: 39925220
Update the two following lines as needed.

Const lStartColumn As Long = 2
Const lEndColumn As Long = 7

Open in new window

0
 
LVL 5

Author Comment

by:CalmSoul
ID: 39925223
Sorry man! I was not expecting columns to be 11 ...now this one is for 6 or 11?
0
 
LVL 39

Expert Comment

by:nutsch
ID: 39925231
This one is for seven columns. For 11 columns, i.e. columns B through L, use:

Const lStartColumn As Long = 2
Const lEndColumn As Long = 11

Thomas
0
 
LVL 5

Author Comment

by:CalmSoul
ID: 39925504
its not working with this data - I don't get it, please help
Book2.csv
0
 
LVL 39

Accepted Solution

by:
nutsch earned 500 total points
ID: 39925559
I ran the code below (with the 11 parameter) on your csv file and, after a minute and a half of churning, got the attached output. Is that what you need?


Sub MoveColumns()
Dim lLoop As Long, rgBlanks As range, lCount As Long, rgBlock As range, bKeepMoving As Boolean

Dim lLastRow As Long, lRowLoop As Long
Debug.Print Now()
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row

'turn off updates to speed up code execution
With application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

Const lStartColumn As Long = 2
Const lEndColumn As Long = 11


For lLoop = lStartColumn To lEndColumn
     
    Do While application.WorksheetFunction.CountA(range(Cells(2, lLoop), Cells(lLastRow, lLoop))) <> range(Cells(2, lLoop), Cells(lLastRow, lLoop)).Cells.Count
    
        bKeepMoving = False
    
        Set rgBlanks = range(Cells(2, lLoop), Cells(lLastRow, lLoop)).SpecialCells(xlCellTypeBlanks)
         
        For Each rgBlock In rgBlanks.Areas
         
            If lLoop < lEndColumn Then
                If application.WorksheetFunction.CountA(rgBlock.Offset(0, 2).Resize(, lEndColumn - lLoop)) > 0 Then bKeepMoving = True
            End If
         
            rgBlock.Offset(0, 1).Resize(, lEndColumn - lLoop + 1).Cut rgBlock.Resize(, lEndColumn - lLoop + 1)
         
        Next rgBlock
        
        If Not bKeepMoving Then Exit Do
    Loop
Next lLoop


With application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With

Debug.Print Now()
End Sub
                                            

Open in new window

Book2.csv
0
 
LVL 5

Author Comment

by:CalmSoul
ID: 39925593
I think my data is the problem....  it might have some funny character in it
0
 
LVL 39

Expert Comment

by:nutsch
ID: 39926352
Are your blank cells really blank or are they just empty? If you do F5 / Special / Blanks, do they get selected?
0

Featured Post

Salesforce Made Easy to Use

On-screen guidance at the moment of need enables you & your employees to focus on the core, you can now boost your adoption rates swiftly and simply with one easy tool.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
Excel VBA - Import Mail Headers in Excel from Specific Folder 3 37
NEED TO LOOK FOR EXACT NUMBER 14 42
Excel (XLSM) on iPad 3 31
Custom fill series 12 36
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

739 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question