Solved

move columns

Posted on 2014-03-12
13
179 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
  • 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
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
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

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa‚Ķ

756 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