Using UNION and Ranges To Speed Up Deleting Columns? [duplicate] - vba

Question

This question already has answers here:
Improving the performance of FOR loop
(3 answers)
Closed 7 years ago.
Trying to use Union and ranges to speed up deleting empty columns, across all sheets in my workbook, except "AA" and "Word Frequency"
Sample workbook
Example of sheet before:
Example of sheet after (note, I will need to write separate script to shift keywords up, you can't see all the keywords, but only the columns with data in them are left):
In my search for a method to speed up deleting columns in a sheet if the column is empty (except the header), I was directed by #chrisneilsen to reference the thread Improving the performance of FOR loop.
That thread shed light on the fact 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.
As a VBA noob, I used to following references to learn about Ranges, Union, UBound and LBound to understand the code in the thread mentioned above:
Excel-Easy.com: Using UBound and LBound, Dynamic Arrays (Using ReDim)
Youtube: Using UNION method to select (and modify) multiple ranges
My old (slow) script that works, but takes about about 3 hours to run across ~30 sheets and deleting ~100 columns each sheet:
Sub Delete_No_Data_Columns()
Dim col As Long
Dim h 'to store the last columns/header
h = Range("E1").End(xlToRight).Column 'find the last column with the data/header
Application.ScreenUpdating = False
For col = h To 5 Step -1
If Application.CountA(Columns(col)) = 1 Then Columns(col).Delete
Next col
End Sub
Almost working script (for one sheet), using the same approach as #chrisneilsen code in thread mentioned above. When I run it, it doesn't do anything, however #chrisneilsen noted there were 2 syntax errors (Column. instead of Columns.) and that I was mixing an implicit ActiveSheet (by using Columns without a qualifier) with an explicit sheet Worksheets("Ball Shaker"). Errors in code are commented below.
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
Dim ws as Worksheet '<<<<<<<<< Fixing Error (qualifying "Columns." properly)
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 >>>>>>>>>>>>>>
Set ws = ActiveSheet
h = Range("E1").End(xlToRight).Column 'find the last column with the data/header
'<<<<<<<<<<<<<< Errors corrected below in comments >>>>>>>>>>>>
For col = h To 5 Step -1
If Application.CountA(Column(col)) = 1 Then
'<<<<< should be Application.CountA(ws.Columns(col)) = 1
If columnsToDelete Is Nothing Then
Set columnsToDelete = Worksheets("Ball Shaker").Column(col)
'should be columnsToDelete = ws.Columns(col)
Else
Set columnsToDelete = Application.Union(columnsToDelete, Worksheets("Ball Shaker").Column(col))
'should be columnsToDelete = Application.Union(columnsToDelete, ws.Columns(col))
End If
End If
Next col
'<<<<<<<<<<<<<< End Errors >>>>>>>>>>>>>>>>
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
Working code that runs across all sheets in workbook, in about ~6 minutes (except "AA" and "Word Frequency" worksheets, which I don't need to format):
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
Note: Trying to delete columns and shift to left, so columns with data inside will all be grouped together neatly after script is run.
Is this the best way to utilize Union and ranges for deleting columns? Any help would be greatly appreciated.

Answer 1

The special cells method actually will not serve you so well here. Instead, find the last row of data in your sheet and delete only the cells in the column up to the that row and shift everything to the left. This will be much faster than deleting an entire column!
Sub Delete_No_Data_Columns()
Dim col As Long, lRow as Long
Dim h as Long'to store the last columns/header
lRow = Range("E" & Rows.Count).End(xlUp).Row ' assumes column E will have last used row ... adjust as needed
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
Range(Cells(2,col),Cells(lRow,col)).Delete shift:=xlToLeft
End If
Next col
Application.ScreenUpdating = False ' i think you want this at the beginning of the program, no?
End Sub