Remove Blank (Empty) Columns Excel VBA

Question

I humbly ask for help modifying this code. I have created an access database which is the information repository for approximately 30 versions of an excel spreadsheet to use for retrieving the most up-to-date information for the workbook. After the workbook has updated the information in the helper sheets, and the user enters the appropriate fields, there are MANY unused columns and rows that need to be removed. Each of the helper sheets dynamically pull data using formulas; therefore, the cells are not truly Empty. I found this code which works amazingly well for removing empty cells, but I cannot figure out how to modify it so that it removes the columns which store formulas that are not being used.

Sub RemoveBlankRowsColumns()
    Dim rng As Range
    Dim rngDelete As Range
    Dim RowCount As Long, ColCount As Long
    Dim EmptyTest As Boolean, StopAtData As Boolean
    Dim RowDeleteCount As Long, ColDeleteCount As Long
    Dim x As Long
    Dim UserAnswer As Variant

'Analyze the UsedRange
    Set rng = ActiveSheet.UsedRange
    rng.Select

    RowCount = rng.Rows.Count
    ColCount = rng.Columns.Count
    DeleteCount = 0

'Determine which cells to delete
    UserAnswer = MsgBox("Do you want to delete only the empty rows & columns " & _
    "outside of your data?" & vbNewLine & vbNewLine & "Current Used Range is " & rng.Address, vbYesNoCancel)

    If UserAnswer = vbCancel Then
        Exit Sub
    ElseIf UserAnswer = vbYes Then
        StopAtData = True
    End If

'Optimize Code
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

'Loop Through Rows & Accumulate Rows to Delete
    For x = RowCount To 1 Step -1
'Is Row Not Empty?
        If Application.WorksheetFunction.CountBlank(rng.Rows(x)) <> 0 Then
            If StopAtData = True Then Exit For
        Else
            If rngDelete Is Nothing Then Set rngDelete = rng.Rows(x)
            Set rngDelete = Union(rngDelete, rng.Rows(x))
            RowDeleteCount = RowDeleteCount + 1
        End If
    Next x

'Delete Rows (if necessary)
    If Not rngDelete Is Nothing Then
        rngDelete.EntireRow.Delete Shift:=xlUp
        Set rngDelete = Nothing
    End If

'Loop Through Columns & Accumulate Columns to Delete
    For x = ColCount To 1 Step -1
'Is Column Not Empty?
        If Application.WorksheetFunction.CountBlank(rng.Columns(x)) <> 0 Then
            If StopAtData = True Then Exit For
        Else
            If rngDelete Is Nothing Then Set rngDelete = rng.Columns(x)
            Set rngDelete = Union(rngDelete, rng.Columns(x))
            ColDeleteCount = ColDeleteCount + 1
        End If
    Next x

'Delete Columns (if necessary)
    If Not rngDelete Is Nothing Then
        rngDelete.Select
        rngDelete.EntireColumn.Delete
    End If

'Refresh UsedRange (if necessary)
    If RowDeleteCount + ColDeleteCount > 0 Then
        ActiveSheet.UsedRange
    Else
        MsgBox "No blank rows or columns were found!", vbInformation, "No Blanks Found"
    End If

ExitMacro:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    rng.Cells(1, 1).Select
End Sub

Screenshot of spreadsheet

In the Screenshot of spreadsheet, cells A1-T221 are active and are being used in the workbook; however,

Rows 222:5000 have formulas that are not being used in this workbook.
Columns T1:EP5000 have formulas that are not being used in this workbook.

Again- Thank you in advance for your help with finding a solution to this modification need.

Gary's Student Gary's Student · Accepted Answer · 2017-08-02T13:49:55

Because the worksheet function COUNTBLANK() will count both empty cells as well as cells containing formulas returning NULL, we can use:

Sub KolumnKleaner()
    Dim N As Long, wf As WorksheetFunction, M As Long
    Dim i As Long, j As Long

    N = Columns.Count
    M = Rows.Count
    Set wf = Application.WorksheetFunction

    For i = N To 1 Step -1
        If wf.CountBlank(Columns(i)) <> M Then Exit For
    Next i

    For j = i To 1 Step -1
        If wf.CountBlank(Columns(j)) = M Then
            Cells(1, j).EntireColumn.Delete
        End If
    Next j
End Sub

will remove all "empty" columns.

Might be a little slow.

EDIT#1:

This version may be faster:

Sub KolumnKleaner2()
    Dim N As Long, wf As WorksheetFunction, M As Long
    Dim i As Long, j As Long

    N = Columns.Count
    M = Rows.Count
    Set wf = Application.WorksheetFunction
    Application.ScreenUpdating = False

    For i = N To 1 Step -1
        If wf.CountBlank(Columns(i)) <> M Then Exit For
    Next i

    For j = i To 1 Step -1
        If wf.CountBlank(Columns(j)) = M Then
            Cells(1, j).EntireColumn.Delete
        End If
    Next j

    Application.ScreenUpdating = True
End Sub

Remove Blank (Empty) Columns Excel VBA

Screenshot of spreadsheet

1 Answers