delete blank rows and columns except headers

Serafin54

Board Regular
Joined
Apr 11, 2014
Messages
69
Office Version
  1. 2016
Platform
  1. Windows
Hello all,

I have this code that i really like and though it works pretty well, what would i change to have it ignore the headers in a spreadsheet when determining blank columns. I have spreadsheets with headers and nothing under them so really don't need them at all. Thanks!

VBA Code:
Sub DeleteEmptyRowsAndColumns(control As IRibbonControl)
'PURPOSE: Remove blank rows or columns contained in the spreadsheets UsedRange
'SOURCE: www.TheSpreadsheetGuru.com

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.CountA(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.CountA(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
  rng.Cells(1, 1).Select
 
End Sub
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
52,274
Office Version
  1. 365
Platform
  1. Windows
I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

This does not have some of the 'extra' bits your code has but this is one way to delete blank rows and blank columns or columns with only header.
See if any parts of this are of use to you.
If your data is very large (tens of thousands of rows) and the code is too slow, post back as there may be a faster way (but with longer code)

VBA Code:
Sub Delete_Empties()
  Dim i As Long, x As Long
  Dim rngDelete As Range
  
  With ActiveSheet
    For i = 1 To .UsedRange.Rows.Count
      x = .Cells(i, Columns.Count).End(xlToLeft).Column
      If x = 1 And IsEmpty(.Cells(i, 1).Value) Then
        If rngDelete Is Nothing Then Set rngDelete = .Rows(i)
        Set rngDelete = Union(rngDelete, .Rows(i))
      End If
    Next i
    If Not rngDelete Is Nothing Then
      rngDelete.Delete
      Set rngDelete = Nothing
    End If
    For i = 1 To .UsedRange.Columns.Count
      x = .Cells(Rows.Count, i).End(xlUp).Row
      If x = 1 Then
        If rngDelete Is Nothing Then Set rngDelete = .Columns(i)
        Set rngDelete = Union(rngDelete, .Columns(i))
      End If
    Next i
    If Not rngDelete Is Nothing Then
      rngDelete.Delete
      Set rngDelete = Nothing
    End If
  End With
End Sub
 

Serafin54

Board Regular
Joined
Apr 11, 2014
Messages
69
Office Version
  1. 2016
Platform
  1. Windows
I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

This does not have some of the 'extra' bits your code has but this is one way to delete blank rows and blank columns or columns with only header.
See if any parts of this are of use to you.
If your data is very large (tens of thousands of rows) and the code is too slow, post back as there may be a faster way (but with longer code)

VBA Code:
Sub Delete_Empties()
  Dim i As Long, x As Long
  Dim rngDelete As Range
 
  With ActiveSheet
    For i = 1 To .UsedRange.Rows.Count
      x = .Cells(i, Columns.Count).End(xlToLeft).Column
      If x = 1 And IsEmpty(.Cells(i, 1).Value) Then
        If rngDelete Is Nothing Then Set rngDelete = .Rows(i)
        Set rngDelete = Union(rngDelete, .Rows(i))
      End If
    Next i
    If Not rngDelete Is Nothing Then
      rngDelete.Delete
      Set rngDelete = Nothing
    End If
    For i = 1 To .UsedRange.Columns.Count
      x = .Cells(Rows.Count, i).End(xlUp).Row
      If x = 1 Then
        If rngDelete Is Nothing Then Set rngDelete = .Columns(i)
        Set rngDelete = Union(rngDelete, .Columns(i))
      End If
    Next i
    If Not rngDelete Is Nothing Then
      rngDelete.Delete
      Set rngDelete = Nothing
    End If
  End With
End Sub
Sorry. I didn't realize my info wasn't complete. I did update that and will test out the code on some of the larger files throughout the day and hopefully know more on a larger sample base but did just try on a test 11k row file and it worked instantly so thank you very much right off the bat. There are those times when there are blank cells and Excel says no blanks to be found. I haven't figured out why that is but do you think this would see them as blank?
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
52,274
Office Version
  1. 365
Platform
  1. Windows
I did update that
Thanks for that. (y)

There are those times when there are blank cells and Excel says no blanks to be found. I haven't figured out why that is but do you think this would see them as blank?
No way of knowing without sample data where that happens. Simplest thing is for you to test it in one of those circumstances. :)
 

Serafin54

Board Regular
Joined
Apr 11, 2014
Messages
69
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

Thanks. If I notice anything I will let you know. I did run it for a file that had 2061 columns and it took about 25 seconds to complete. Not sure if this is what you were talking about earlier. That isn't too bad for that many imo but if that seems like a lot to you, i'm not sure.
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
52,274
Office Version
  1. 365
Platform
  1. Windows
I did run it for a file that had 2061 columns and it took about 25 seconds to complete.
Give this version a try & see if it is any better.

VBA Code:
Sub Delete_Empties_v2()
  Dim a As Variant, b As Variant
  Dim nc As Long, nr As Long, i As Long, k As Long, x As Long
  
 'Delete empty rows
  nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
  nr = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
  a = Range("A1").Resize(nr - 1).Value
  ReDim b(1 To nr - 1, 1 To 1)
  For i = 1 To nr - 1
    x = Cells(i, Columns.Count).End(xlToLeft).Column
    If x = 1 And IsEmpty(a(i, 1)) Then
      b(i, 1) = 1
      k = k + 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    With Range("A1").Resize(nr - 1, nc)
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlYes, Orientation:=xlTopToBottom
      .Offset(1).Resize(k).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
  End If
  
  'Delete empty columns
  nr = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
  ReDim b(1 To 1, 1 To nc - 1)
  k = 0
  For i = 1 To nc - 1
    x = Cells(Rows.Count, i).End(xlUp).Row
    If x = 1 Then
      b(1, i) = 1
      k = k + 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    With Range("A1").Resize(nr, nc - 1)
      .Rows(nr).Value = b
      .Sort Key1:=.Rows(nr), Order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight
      .Resize(, k).EntireColumn.Delete
    End With
    Application.ScreenUpdating = True
  End If
End Sub
 
Solution

Serafin54

Board Regular
Joined
Apr 11, 2014
Messages
69
Office Version
  1. 2016
Platform
  1. Windows
yes. This one was instant. Thank you very much!
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
52,274
Office Version
  1. 365
Platform
  1. Windows
You're welcome. Sounds like a significant reduction in time. :biggrin:
Thanks for the follow-up. (y)
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,151,957
Messages
5,767,308
Members
425,403
Latest member
MellieD

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top