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 · Accepted Answer · 2017-08-02 15:36:12Z

0

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

edited Aug 2, 2017 at 15:36

answered Aug 2, 2017 at 13:49

Gary's Student

96.9k10 gold badges66 silver badges104 bronze badges

Sign up to request clarification or add additional context in comments.

2 Comments

mbass438 Over a year ago

I appreciate the effort to propose another solution to my problem. Each time I run the code, it causes my excel to stop responding. I assumed that it was simply because of the large amount of processes being completed; however, after 30 minutes, it still did not respond.

mbass438 Over a year ago

@garys-student EDIT#1 definitely processed much faster. It effectively deleted all of the columns in the spreadsheet that did not have anything stored in any of the cells (Blank); however, I need this VBA script to to delete all of the columns that have no value in the cell (refer to Screenshot of spreadsheet): Col Q, and its helper Col R, are being used, but Col U (helper V) is not being used as a result of the users entry, yet they still have formulas in each of the cells (1:5000) to pull data if the user enters appropriate values. How do I delete unused cells with formulas, too?

Collectives™ on Stack Overflow

Remove Blank (Empty) Columns Excel VBA

Screenshot of spreadsheet

1 Answer 1

2 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

Screenshot of spreadsheet

1 Answer 1

2 Comments

Your Answer

Sign up or log in

Post as a guest

Related