Delete empty rows/columns and reset last cell

[Nanogirl21]

Using VBA how do I delete all empty rows and columns and reset last cell?


Column A can be used to determine the last row, but the last column will always be different.

 

[Joe4]

How is your data structured?
Where are these blank rows and columns? In the middle of the data, or at the end of the data?
If at the end, there typically shouldn't be a need to delete them.

You can get the last row in column A with data like this:

Dim lastrow as Long
lastrow = Cells(Rows.Count,"A").End(xlUp).Row

 

[JLGWhiz]

Sub t()
With ActiveSheet
    .UsedRange.AutoFilter 1, "="
    .UsedRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
    .AutoFilterMode = False
    For Each col In .UsedRange.Offset(1).Columns
       If Application.CountA(col) = 0 Then col.EntireColumn.Delete
    Next
    lastRw = .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
End With
End Sub

 

[Nanogirl21]

Sub t()
With ActiveSheet
    .UsedRange.AutoFilter 1, "="
    .UsedRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
    .AutoFilterMode = False
    For Each col In .UsedRange.Offset(1).Columns
       If Application.CountA(col) = 0 Then col.EntireColumn.Delete
    Next
    lastRw = .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
End With
End Sub

I tried this, but it is not working. It is refreshing all the cells, but not deleteing rows and columns that are empty.

 

[JLGWhiz]

This will probably work better.

Sub t2()
With ActiveSheet
    For i = .UsedRange.Rows.Count To 2 Step -1
        If Application.CountA(Rows(i)) = 0 Then Rows(i).Delete
    Next
    .AutoFilterMode = False
    For j = .UsedRange.Columns.Count To 1 Step -1
       If Application.CountA(Columns(j)) = 0 Then Columns(j).Delete
    Next
    lastRw = .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
End With
MsgBox lastRw
End Sub

If your cells have formulas that yeild "" values in cells, then the code fails.

 

[Nanogirl21]

How is your data structured?
Where are these blank rows and columns? In the middle of the data, or at the end of the data?
If at the end, there typically shouldn't be a need to delete them.

You can get the last row in column A with data like this:

Dim lastrow as Long
lastrow = Cells(Rows.Count,"A").End(xlUp).Row

I have data on multiple sheets. Each sheet has a different number of rows and columns. There are black rows and columns at the end of the data and the some are in the middle of the data. I was able to find this code online. It does exactly what I want, but I am trying to modify it to work on every sheet instead of only the active sheet.

Sub RemoveBlankRowsColumns()
'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

'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 the current worksheet's Used Range
  ActiveSheet.UsedRange
  
  'Trim Clean
     With ActiveSheet.UsedRange
      .Value = Evaluate("if({1},trim(clean(substitute(" & .Address & ",char(160),"" ""))))")
   End With

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

 

[Joe4]

Here is how you can run it against all sheets (new parts added in red):

[FONT=monospace]Sub RemoveBlankRowsColumns()
'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
[COLOR=#ff0000]Dim ws as Worksheet

For each ws in Worksheets
    ws.Activate[/COLOR]

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

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

'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 the current worksheet's Used Range
    ActiveSheet.UsedRange
  
  'Trim Clean
    With ActiveSheet.UsedRange
        .Value = Evaluate("if({1},trim(clean(substitute(" & .Address & ",char(160),"" ""))))")
    End With

ExitMacro:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    rng.Cells(1, 1).Select
  
[COLOR=#ff0000]Next ws[/COLOR]
  
End Sub[/FONT]

 

[JLGWhiz]

Edit