Delete Blank rows in all WB Tables

[JEH0714]

I am currently using the code below to delete blank rows in tables but this code requires me to list every table separately and run the code on every WS. I was wondering if there was a way to loop through all tables within a WB and delete blank rows in all tables within that WB.

Thank you

Sub sbVBS_To_Delete_Blank_Rows_In_Table()
Dim iCntr As Long
Dim rng As Range
Dim rng2 As Range
Dim rng3 As Range

Set rng = ActiveSheet.ListObjects("Table1").Range
Set rng2 = ActiveSheet.ListObjects("Table2").Range
Set rng3 = ActiveSheet.ListObjects("Table3").Range

For iCntr = rng.row + rng.Rows.Count - 1 To rng.row Step -1
        If Application.WorksheetFunction.CountA(Rows(iCntr)) = 0 Then Rows(iCntr).EntireRow.Delete
    Next

For iCntr = rng2.row + rng2.Rows.Count - 1 To rng2.row Step -1
        If Application.WorksheetFunction.CountA(Rows(iCntr)) = 0 Then Rows(iCntr).EntireRow.Delete

    Next

For iCntr = rng3.row + rng3.Rows.Count - 1 To rng3.row Step -1
        If Application.WorksheetFunction.CountA(Rows(iCntr)) = 0 Then Rows(iCntr).EntireRow.Delete

    Next

End Sub

 

[KOKOSEK]

Sub DoItForAllSheets()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
    ws.Activate
    call sbVBS_To_Delete_Blank_Rows_In_Table
Next
End Sub

Should works

 

[JEH0714]

But wouldn't that still require having every table on every WS spelled out within the code? Tables are add to new WS daily so I am looking for a way to just loop through every table on every WS, even the newly added ones without having to alter the code for every table that is added.

 

[Domenic]

Maybe something like this....

Option Explicit

Sub Delete_Blank_Rows_in_All_Tables_in_Workbook()

    Dim targetWorkbook As Workbook
    Set targetWorkbook = ActiveWorkbook
    
    Dim currentWorksheet As Worksheet
    For Each currentWorksheet In targetWorkbook.Worksheets
        Dim currentListObject As ListObject
        For Each currentListObject In currentWorksheet.ListObjects
            Delete_Blank_Rows_in_Table currentListObject
        Next currentListObject
    Next currentWorksheet
    
End Sub

Sub Delete_Blank_Rows_in_Table(ByVal listObj As ListObject)

    With listObj
        Dim rowIndex As Long
        For rowIndex = .ListRows.Count To 1 Step -1
            Dim currentRow As Range
            Set currentRow = .ListRows(rowIndex).Range
            If Application.CountA(currentRow) = 0 Then
                currentRow.Delete
            End If
        Next rowIndex
    End With
    
End Sub

Hope this helps!

 

[JEH0714]

Worked like a charm thank you so much.

 

[Domenic]

You're very welcome, cheers!