Excel memory through the roof while deleting empty columns - vba

Question

I have a very strange problem with some Excel VBA code I created.
I won't get into the specifics (unless needed), but I have code which filters and copies data from one sheet to another.
On this second sheet it checks for empty columns and deletes them.
I have created this small macro to do the delete-part:
Public Sub deleteemptyrows()
Dim C As Integer
Range("A1").Select
Application.CutCopyMode = False
C = ActiveSheet.Cells.SpecialCells(xlLastCell).Column
Do Until C = 0
If WorksheetFunction.CountA(Columns(C)) = 1 Then
Columns(C).Delete
End If
Debug.Print C
C = C - 1
Loop
End Sub
Now this macro works perfectly and superfast (for the approx. 500 columns I'm checking every time) but the problem occurs when I call this macro in my VBA code (after the code copies the filtered data).
When it reaches the line Columns(C).Delete the memory of EXCEL.exe is going up to 6 GB in task manager, and it's running very, very slow column by column.
I have added the Application.CutCopyMode = False line because I thought it might have the copied data in it's memory, but that didn't help.
Any idea on how to fix this? Thanks!

Answer 1

Whilst you need to loop over the columns in the used range of the sheet - you don't need to delete them one-by-one. You can build a range - using Union - to create a non-contiguous range of columns with only headers and then delete them all in a single go. Using this technique in with disabling various properties of Application should give you an efficient method:
Option Explicit
Sub DeleteColumnsEfficiently()
Dim ws As Worksheet
Dim rngEmptyColumns As Range
Dim rngColumn As Range
Dim wsf As WorksheetFunction
Dim lngSetting As Long
' set a reference to worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
' set reference to WorksheetFunction
Set wsf = Application.WorksheetFunction
' initialise range of empty columns
Set rngEmptyColumns = Nothing
' set application settings to optimise ui change
With Application
.ScreenUpdating = False
.EnableEvents = False
lngSetting = .Calculation
.Calculation = xlCalculationManual
End With
' loop columns in usedrange
For Each rngColumn In ws.UsedRange.Columns
' check if only header populated
If wsf.CountA(rngColumn) = 1 Then
' if just header - then add to range of columns
If rngEmptyColumns Is Nothing Then
Set rngEmptyColumns = rngColumn.Offset
Else
Set rngEmptyColumns = Application.Union(rngEmptyColumns, rngColumn)
End If
End If
Next rngColumn
' delete columns with only header
rngEmptyColumns.Delete
' reset application settings
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngSetting
End With
End Sub

Answer 2

If you are trying to run the sub routine by passing the sheet string, you may try the Robin's code as below...
Remember you are supposed to place this code on a Standard Module like Module1, Module2 etc. after inserting a New Module not on ThisWorkbook Module as you did in the sample workbook.
Option Explicit
Sub DeleteColumnsEfficiently(ByVal strSheetName As String)
Dim ws As Worksheet
Dim rngEmptyColumns As Range
Dim rngColumn As Range
Dim wsf As WorksheetFunction
Dim lngSetting As Long
' set a reference to worksheet
Set ws = ThisWorkbook.Worksheets(strSheetName)
' set reference to WorksheetFunction
Set wsf = Application.WorksheetFunction
' initialise range of empty columns
Set rngEmptyColumns = Nothing
' set application settings to optimise ui change
With Application
.ScreenUpdating = False
.EnableEvents = False
lngSetting = .Calculation
.Calculation = xlCalculationManual
End With
' loop columns in usedrange
For Each rngColumn In ws.UsedRange.Columns
rngColumn.Select
rngColumn.Offset.Select
' check if only header populated
If wsf.CountA(rngColumn) = 1 Then
' if just header - then add to range of columns
If rngEmptyColumns Is Nothing Then
Set rngEmptyColumns = rngColumn
Else
Set rngEmptyColumns = Application.Union(rngEmptyColumns, rngColumn)
End If
End If
Next rngColumn
' delete columns with only header
If Not rngEmptyColumns Is Nothing Then
rngEmptyColumns.Delete
End If
' reset application settings
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngSetting
End With
End Sub
Sub Test()
DeleteColumnsEfficiently "Sheet1"
End Sub