Solved

move columns

Posted on 2014-03-12
13
178 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
Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

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.

 
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: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering 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

This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

808 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