?
Solved

move columns

Posted on 2014-03-12
13
Medium Priority
?
182 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
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
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 2000 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

Industry Leaders: 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!

Question has a verified solution.

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

This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

765 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