delete blank rows and columns except headers

[Serafin54]

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!

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

 

[Peter_SSs]

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)

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]

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)

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]

I did update that

Thanks for that.

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]

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]

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.

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

 

[Serafin54]

yes. This one was instant. Thank you very much!

 

[Peter_SSs]

You're welcome. Sounds like a significant reduction in time.
Thanks for the follow-up.