Are you just trying to delete columns that have only 1 cell with data?
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: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
Are you just trying to delete columns that have only 1 cell with data?
Office 2010/365
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?
This seems to work
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.Code: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
Last edited by JLGWhiz; Feb 2nd, 2016 at 07:12 PM.
Using Windows 10, Excel 2013.
Any code provided by me should be tested on a copy or a mock-up of your file before applying it to your original file. Some actions generated by VBA code cannot be reversed with the undo facility in Excel. To open the VB editor, press Alt + F11. To run code from the Excel window, press Alt + F8. Please do not attempt to learn everything about VBA in one thread, especially from me. See this link for attaching images: Attachments
Yes, each column will have a header (1 cell with data)
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)
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)
--------------------------------------
Code: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
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
Use the MrExcel HTML Maker to post nicely formatted tables in your forum posts.
Find a link in post number 31
The more we learn, and the better we get at our trade, the easier it becomes to overlook the obvious.
Life moves pretty fast. If you don't stop and look around once in a while, you could miss it.
Ferris Bueller A.K.A. John Hughes, 1986
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.
Last edited by Jonmo1; Feb 2nd, 2016 at 09:02 PM.
Use the MrExcel HTML Maker to post nicely formatted tables in your forum posts.
Find a link in post number 31
The more we learn, and the better we get at our trade, the easier it becomes to overlook the obvious.
Life moves pretty fast. If you don't stop and look around once in a while, you could miss it.
Ferris Bueller A.K.A. John Hughes, 1986
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:
at the start of my code, as effectively this ignores errors, and the code/results will not behave as expected.Code:On Error GoTo Somewhere 'where Somewhere: doesn't actually handle errors! 'or On Error Resume Next
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/...r_Handling.pdf
On Error WTF? | Excel Matters
Just out of curiosity, how fast does this code run for your data...
Code: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
Last edited by Rick Rothstein; Feb 3rd, 2016 at 12:29 AM.
Rick's "mini" blog... http://www.excelfox.com/forum/f22/
.
Want to post a small screen shot? See Part B here.
Like this thread? Share it with others