Using UNION and Ranges To Speed Up Deleting Many Columns?

[eryksd]

Trying to use Union and ranges to speed up deleting empty columns, but going wrong somewhere with the code.

I read here that deleting columns individually slows down performance significantly. Script speed can be improved by defining a "master" range to include all the ranges (columns) to be deleted (by using Union), and then simply deleting the "master" range.

My old (slow) script that works, but takes about about 3 hours to run across ~30 sheets and deleting ~100 columns each sheet. Using Union is supposed to make the process run in seconds instead of hours, was hoping someone could help me figure out what I'm doing wrong with my code. When I run it, nothing happens... not sure what's going on.

Any help would be greatly appreciated!

<code style="margin: 0px; padding: 0px; font-style: inherit; font-weight: inherit;">Sub Delete_No_Data_Columns_Optimized()

    Dim col As Long
    Dim h 'to store the last columns/header
    Dim EventState As Boolean, CalcState As XlCalculation, PageBreakState As Boolean
    Dim columnsToDelete As Range

    On Error GoTo EH:
    'Optimize Performance

    Application.ScreenUpdating = False
    EventState = Application.EnableEvents
    Application.EnableEvents = False

    CalcState = Application.Calculation
    Application.Calculation = xlCalculationManual

    PageBreakState = ActiveSheet.DisplayPageBreaks
    ActiveSheet.DisplayPageBreaks = False

' <<<<<<<<<<<<< MAIN CODE >>>>>>>>>>>>>>

    h = Range("E1").End(xlToRight).Column 'find the last column with the data/header


    For col = h To 5 Step -1
        If Application.CountA(Columns(col)) = 1 Then  
            If columnsToDelete Is Nothing Then
                Set columnsToDelete = Worksheets("Ball Shaker").Column(col)
                
            Else
                Set columnsToDelete = Application.Union(columnsToDelete, Worksheets("Ball Shaker").Column(col))
                
            End If
        End If
    Next col

    If Not columnsToDelete Is Nothing Then
        columnsToDelete.Delete
    End If

' <<<<<<<<<<<< END MAIN CODE >>>>>>>>>>>>>>

CleanUp:
    'Revert optmizing lines
    On Error Resume Next
    ActiveSheet.DisplayPageBreaks = PageBreakState
    Application.Calculation = CalcState
    Application.EnableEvents = EventState
    Application.ScreenUpdating = True
Exit Sub
EH:
    ' Handle Errors here

    Resume CleanUp
End Sub</code>

 

[Scott Huish]

Are you just trying to delete columns that have only 1 cell with data?

 

[StephenCrump]

You have: On Error GoTo EH which is dangerous, because your code can error anywhere, and then it will appear that "nothing happens".

Your code will error because you need to refer to .Columns(col)

Your code also is hard coded for Worksheets("Ball Shaker"). I assume you want to loop through multiple sheets?

 

[JLGWhiz]

This seems to work

Sub Delete_No_Data_Columns_Optimized()
    Dim col As Long
    Dim h 'to store the last columns/header
    Dim EventState As Boolean, CalcState As XlCalculation, PageBreakState As Boolean
    Dim columnsToDelete As Range
    On Error GoTo EH:
    'Optimize Performance
    Application.ScreenUpdating = False
    EventState = Application.EnableEvents
    Application.EnableEvents = False
    CalcState = Application.Calculation
    Application.Calculation = xlCalculationManual
    PageBreakState = ActiveSheet.DisplayPageBreaks
    ActiveSheet.DisplayPageBreaks = False
' <<<<<<<<<<<<< MAIN CODE >>>>>>>>>>>>>>
    h = Range("E1").End(xlToRight).Column 'find the last column with the data/header
    For col = h To 5 Step -1
        If Application.CountA(ActiveSheet.Columns(col)) >= 1 Then
            If columnsToDelete Is Nothing Then
                Set columnsToDelete = Worksheets("Ball Shaker").Columns(col)
            Else
                Set columnsToDelete = Application.Union(columnsToDelete, Worksheets("Ball Shaker").Columns(col))
                
            End If
        End If
    Next col
    If Not columnsToDelete Is Nothing Then
        columnsToDelete.Delete
    End If
' <<<<<<<<<<<< END MAIN CODE >>>>>>>>>>>>>>
CleanUp:
    MsgBox Err.Number    'Revert optmizing lines
    On Error Resume Next
    ActiveSheet.DisplayPageBreaks = PageBreakState
    Application.Calculation = CalcState
    Application.EnableEvents = EventState
    Application.ScreenUpdating = True
Exit Sub
EH:
    ' Handle Errors here
    Resume CleanUp
End Sub

If you are trying to delete only the columns with one cell of value, then remove the GreaterThan symbol from the CountA statement. There were a couple of typos ibn the Columns(col) with the 's' missing.

 

[eryksd]

Are you just trying to delete columns that have only 1 cell with data?

Yes, each column will have a header (1 cell with data)

You have: On Error GoTo EH which is dangerous, because your code can error anywhere, and then it will appear that "nothing happens".

Your code will error because you need to refer to .Columns(col)

Your code also is hard coded for Worksheets("Ball Shaker"). I assume you want to loop through multiple sheets?

Good catch on typo, I missed that. Any suggestions on how to handle errors on my code? (See my new working code below, across sheets)

This seems to work

Sub Delete_No_Data_Columns_Optimized()
    Dim col As Long
    Dim h 'to store the last columns/header
    Dim EventState As Boolean, CalcState As XlCalculation, PageBreakState As Boolean
    Dim columnsToDelete As Range
    On Error GoTo EH:
    'Optimize Performance
    Application.ScreenUpdating = False
    EventState = Application.EnableEvents
    Application.EnableEvents = False
    CalcState = Application.Calculation
    Application.Calculation = xlCalculationManual
    PageBreakState = ActiveSheet.DisplayPageBreaks
    ActiveSheet.DisplayPageBreaks = False
' <<<<<<<<<<<<< MAIN CODE >>>>>>>>>>>>>>
    h = Range("E1").End(xlToRight).Column 'find the last column with the data/header
    For col = h To 5 Step -1
        If Application.CountA(ActiveSheet.Columns(col)) >= 1 Then
            If columnsToDelete Is Nothing Then
                Set columnsToDelete = Worksheets("Ball Shaker").Columns(col)
            Else
                Set columnsToDelete = Application.Union(columnsToDelete, Worksheets("Ball Shaker").Columns(col))
                
            End If
        End If
    Next col
    If Not columnsToDelete Is Nothing Then
        columnsToDelete.Delete
    End If
' <<<<<<<<<<<< END MAIN CODE >>>>>>>>>>>>>>
CleanUp:
    MsgBox Err.Number    'Revert optmizing lines
    On Error Resume Next
    ActiveSheet.DisplayPageBreaks = PageBreakState
    Application.Calculation = CalcState
    Application.EnableEvents = EventState
    Application.ScreenUpdating = True
Exit Sub
EH:
    ' Handle Errors here
    Resume CleanUp
End Sub

If you are trying to delete only the columns with one cell of value, then remove the GreaterThan symbol from the CountA statement. There were a couple of typos ibn the Columns(col) with the 's' missing.

Thank you, yes good catch on Columns type, totally missed that. Working code across sheets below (with fixed typos):

This new code seems to work well (runs in ~6 minutes across all sheets) - hope I'm handling any potential errors the right way though (I'm still pretty new to vba, not familiar with proper error protocols)

--------------------------------------

Option Explicit

Sub Delete_No_Data_Columns_Optimized_AllSheets()


Dim sht As Worksheet


For Each sht In Worksheets
    
    If sht.Name <> "AA" And sht.Name <> "Word Frequency" Then
        sht.Activate    'go to that Sheet!
        Delete_No_Data_Columns_Optimized sht.Index  'run the code, and pass the sht.Index _
                                                    'of the current sheet to select that sheet
    End If
Next sht    'next sheet please!




End Sub


Sub Delete_No_Data_Columns_Optimized(shtIndex As Integer)


    Dim col As Long
    Dim h 'to store the last columns/header
    Dim EventState As Boolean, CalcState As XlCalculation, PageBreakState As Boolean
    Dim columnsToDelete As Range
    Dim ws As Worksheet
    
    Set ws = Sheets(shtIndex)   'Set the exact sheet, not just the one that is active _
                                'and then you will go through all the sheets
    
    On Error GoTo EH:
    'Optimize Performance


    Application.ScreenUpdating = False
    EventState = Application.EnableEvents
    Application.EnableEvents = False


    CalcState = Application.Calculation
    Application.Calculation = xlCalculationManual


    PageBreakState = ActiveSheet.DisplayPageBreaks
    ActiveSheet.DisplayPageBreaks = False
    
' <<<<<<<<<<<<< MAIN CODE >>>>>>>>>>>>>>
    
    h = ws.Range("E1").End(xlToRight).Column 'find the last column with the data/header
    
               
    For col = h To 5 Step -1
        If ws.Application.CountA(Columns(col)) = 1 Then  'Columns(col).Delete
            If columnsToDelete Is Nothing Then
                Set columnsToDelete = ws.Columns(col)
            Else
                Set columnsToDelete = Application.Union(columnsToDelete, ws.Columns(col))
            End If
        End If
    Next col
    
    If Not columnsToDelete Is Nothing Then
        columnsToDelete.Delete
    End If
    
' <<<<<<<<<<<< END MAIN CODE >>>>>>>>>>>>>>
    
CleanUp:
    'Revert optmizing lines
    On Error Resume Next
    ActiveSheet.DisplayPageBreaks = PageBreakState
    Application.Calculation = CalcState
    Application.EnableEvents = EventState
    Application.ScreenUpdating = True
Exit Sub
EH:
    ' Handle Errors here


    Resume CleanUp
End Sub

 

[Jonmo1]

If each column will have a header, so the 1 cell will be row 1.

Instead of invoking the worksheet function COUNTA,
If Application.CountA(Columns(col)) = 1 Then

Try changing that to
If Cells(Rows.Count, col).End(xlUp).Row = 1 Then

 

[Jonmo1]

Also, since you have it split into 2 macros (1 to loop the sheets, 1 to delete the columns of specified sheet)
You should enable/disable the calculations events and such in the FIRST macro, not the macro called by the first.

The way you have it, calculations get disabled/re-enabled for each iteration of the sheet loop.

It would be better to just disable calculations once from the first macro.
Do ALL the sheets
THEN re-enable calculations after all the sheets are done.

 

[StephenCrump]

Any suggestions on how to handle errors on my code?

Once your code is cleaned up and working (e.g. using JLGWhiz's and Jonmo1's suggestions) it will probably work fine for months or years. If it was my code, and I was the only one using it, my inclination would be to deal with errors/unexpected results only if/when they occurred.

What I definitely wouldn't do is to put:

On Error GoTo Somewhere 'where Somewhere: doesn't actually handle errors!
'or
On Error Resume Next

at the start of my code, as effectively this ignores errors, and the code/results will not behave as expected.

If you Google VBA error handling, you'll should find some good resources. Here's just a couple to get you started:

Error Handling In VBA
https://dl.dropboxusercontent.com/u/13737137/Starters/Error_Handling.pdf
On Error WTF? | Excel Matters

 

[Rick Rothstein]

Yes, each column will have a header (1 cell with data)

This new code seems to work well (runs in ~6 minutes across all sheets)

Just out of curiosity, how fast does this code run for your data...

Sub DeleteEmptyColumns()
  Dim X As Long, LastCol As Long, WS As Worksheet
  Dim ScreenUpdateState As Boolean
  Dim StatusBarState As Boolean
  Dim CalcState As Long
  Dim EventsState As Boolean
  Dim DisplayPageBreakState As Boolean
  
  '  Save the current state of Excel settings.
  ScreenUpdateState = Application.ScreenUpdating
  StatusBarState = Application.DisplayStatusBar
  CalcState = Application.Calculation
  EventsState = Application.EnableEvents
  
  '  Turn off Excel functionality to improve performance.
  Application.ScreenUpdating = False
  Application.DisplayStatusBar = False
  Application.Calculation = xlCalculationManual
  Application.EnableEvents = False
  
  For Each WS In Worksheets
    DisplayPageBreakState = WS.DisplayPageBreaks
    WS.DisplayPageBreaks = False
    LastCol = WS.Cells(1, Columns.Count).End(xlToLeft).Column
    For X = 1 To LastCol
      If Application.CountA(WS.Columns(X)) = 1 Then WS.Cells(1, X) = ""
    Next
    On Error Resume Next
    WS.Range("A1").Resize(, LastCol).SpecialCells(xlBlanks).EntireColumn.Delete
    On Error GoTo 0
    WS.DisplayPageBreaks = DisplayPageBreakState
  Next
  
  '  Restore Excel settings to original state.
  Application.ScreenUpdating = ScreenUpdateState
  Application.DisplayStatusBar = StatusBarState
  Application.Calculation = CalcState
End Sub

 

[eryksd]

Just out of curiosity, how fast does this code run for your data...

Sub DeleteEmptyColumns()
  Dim X As Long, LastCol As Long, WS As Worksheet
  Dim ScreenUpdateState As Boolean
  Dim StatusBarState As Boolean
  Dim CalcState As Long
  Dim EventsState As Boolean
  Dim DisplayPageBreakState As Boolean
  
  '  Save the current state of Excel settings.
  ScreenUpdateState = Application.ScreenUpdating
  StatusBarState = Application.DisplayStatusBar
  CalcState = Application.Calculation
  EventsState = Application.EnableEvents
  
  '  Turn off Excel functionality to improve performance.
  Application.ScreenUpdating = False
  Application.DisplayStatusBar = False
  Application.Calculation = xlCalculationManual
  Application.EnableEvents = False
  
  For Each WS In Worksheets
    DisplayPageBreakState = WS.DisplayPageBreaks
    WS.DisplayPageBreaks = False
    LastCol = WS.Cells(1, Columns.Count).End(xlToLeft).Column
    For X = 1 To LastCol
      If Application.CountA(WS.Columns(X)) = 1 Then WS.Cells(1, X) = ""
    Next
    On Error Resume Next
    WS.Range("A1").Resize(, LastCol).SpecialCells(xlBlanks).EntireColumn.Delete
    On Error GoTo 0
    WS.DisplayPageBreaks = DisplayPageBreakState
  Next
  
  '  Restore Excel settings to original state.
  Application.ScreenUpdating = ScreenUpdateState
  Application.DisplayStatusBar = StatusBarState
  Application.Calculation = CalcState
End Sub

Hello Rick, thank you for the code!

It actually ran 32 seconds faster

First solution I listed: 9:29 minutes
Your code: 8:57 minutes