Solved

move columns

Posted on 2014-03-12
13
173 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
Comment Utility
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
Comment Utility
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
Comment Utility
nope this is not working
0
 
LVL 39

Expert Comment

by:nutsch
Comment Utility
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
Comment Utility
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
Comment Utility
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
Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

 
LVL 39

Expert Comment

by:nutsch
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
I think my data is the problem....  it might have some funny character in it
0
 
LVL 39

Expert Comment

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

Featured Post

6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

Join & Write a Comment

This article describes some techniques which will make your VBA or Visual Basic Classic code easier to understand and maintain, whether by you, your replacement, or another Experts-Exchange expert.
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…
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

771 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

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now