Delete Rows in Subtotal Groups if Subtotal is Zero

[NicNac123]

Hi.

I'm a bit of a novice when it comes to code so I need a bit of help.
I've seen a few threads about this but when I copy the code into my workbook it doesn't work for me.

I've subtotalled my data by PO number to SUM the Amounts in column F. I want all the rows that subtotal zero to be deleted.
FOR EXAMPLE: In the attached image the Subtotal of PO000041113 in cell F10 is zero so I want to delete rows 8, 9 and 10 (or even just rows 8 and 9).

The spreadsheet has 4,000+ rows so I don't want to do this manually!

Thanks in advance.

 

[Domenic]

The following macro assumes that the sheet containing the data is the active sheet. Note, though, with more than 4,000 rows of data, you'll likely find it somewhat slow.

Option Explicit

Sub RemoveGroupsWithZeroTotals()

    Dim last_row As Long
    last_row = Cells(Rows.Count, "H").End(xlUp).Row
    
    Dim order_number As String
    Dim current_row As Long
    Dim delete_rows As Boolean
    
    current_row = last_row
    While (current_row > 1)
        order_number = Cells(current_row, "H").Value
        If order_number <> "Grand Total" And Right(order_number, 5) = "Total" And Cells(current_row, "F").Value = 0 Then
            delete_rows = True
            While (current_row > 1) And (delete_rows = True)
                Rows(current_row).Delete
                current_row = current_row - 1
                If Right(Cells(current_row, "H"), 5) = "Total" And Cells(current_row, "F").Value <> 0 Then
                    delete_rows = False
                End If
            Wend
        Else
            current_row = current_row - 1
        End If
    Wend

End Sub

Hope this helps!

 

[NicNac123]

The following macro assumes that the sheet containing the data is the active sheet. Note, though, with more than 4,000 rows of data, you'll likely find it somewhat slow.

Option Explicit

Sub RemoveGroupsWithZeroTotals()

    Dim last_row As Long
    last_row = Cells(Rows.Count, "H").End(xlUp).Row
   
    Dim order_number As String
    Dim current_row As Long
    Dim delete_rows As Boolean
   
    current_row = last_row
    While (current_row > 1)
        order_number = Cells(current_row, "H").Value
        If order_number <> "Grand Total" And Right(order_number, 5) = "Total" And Cells(current_row, "F").Value = 0 Then
            delete_rows = True
            While (current_row > 1) And (delete_rows = True)
                Rows(current_row).Delete
                current_row = current_row - 1
                If Right(Cells(current_row, "H"), 5) = "Total" And Cells(current_row, "F").Value <> 0 Then
                    delete_rows = False
                End If
            Wend
        Else
            current_row = current_row - 1
        End If
    Wend

End Sub

Hope this helps!

Thank you Domenic, this worked perfect! Saved me a lot of time

 

[Domenic]

You're very welcome, I'm glad I could help.

Cheers!

 

[NicNac123]

Insert and run VBA macros in Excel - step-by-step guide

This is a short step-by-step tutorial for beginners showing how to add VBA code (Visual Basic for Applications code) to your Excel workbook and run this macro to solve your spreadsheet tasks.

www.ablebits.com

 

[NicNac123]

I hav

You're very welcome, I'm glad I could help.

Cheers!

I have no idea how you manage to come up with these codes but it's appreciated.

 

[ManiacB]

Here is another approach, solved it too late but someone might be interested

Sub DelPO()
Dim lr, lrs, x, i, j, ttl, u As Long
Dim ws As Worksheet
Dim Rng, Rngs As Range
Dim wsn As String
Application.ScreenUpdating = False
 Set ws = Sheets("Sheet1")
 lr = Cells(Rows.Count, "F").End(xlUp).Row
 
 Set Rng = ws.Range("A1:H" & lr)
 'Set RngH = ws.Range("H1:H" & lr)
 With ws
    
    For i = lr To 1 Step -1
    If InStr((Cells(i, 8)), "Total") = 11 Then GoTo Skip
            With Rng
                .AutoFilter
                'MsgBox Range("H" & (i)).Value
                .AutoFilter Field:=8, Criteria1:=Cells(i, "H").Value
                   'lrs = .SpecialCells(xlCellTypeVisible).Rows.Count
                .SpecialCells(xlCellTypeVisible).Copy
                wsn = Cells(i, "H").Value
                Sheets.Add(After:=Sheets(Sheets.Count)).name = Cells(i, "H").Value
                ActiveSheet.Paste
                ttl = 0
                lrs = Sheets(wsn).Cells(Rows.Count, "H").End(xlUp).Row
                For j = lrs To 2 Step -1
                    Set Rngs = Range("F2:F" & lrs)
                    ttl = WorksheetFunction.Sum(Rngs)
                    If ttl = 0 Then
                        'ws.Cells(i, "I").EntireRow.Delete
                        ws.Cells(i, "I").Value = "Del"
                        'MsgBox ttl
                    End If
                Next j
                
                        Application.DisplayAlerts = False
                            ThisWorkbook.Sheets(wsn).Delete
                        Application.DisplayAlerts = True
            End With
Skip:
    Next i
    ' Turn off filter
    ws.AutoFilterMode = False
    
For u = lr To 1 Step -1
    If ws.Cells(u, "I").Value = "Del" Or (ws.Cells(u, "F").Value = 0 _
    And Right(ws.Cells(u, "H").Value, 5) = "Total") And _
    ws.Cells(u, "H").Value <> "Grand Total" Then
        ws.Cells(u, "I").EntireRow.Delete
    End If
Next u
ws.Activate
End With

Application.ScreenUpdating = True
End Sub

 

[NicNac123]

Here is another approach, solved it too late but someone might be interested

Sub DelPO()
Dim lr, lrs, x, i, j, ttl, u As Long
Dim ws As Worksheet
Dim Rng, Rngs As Range
Dim wsn As String
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1")
lr = Cells(Rows.Count, "F").End(xlUp).Row

Set Rng = ws.Range("A1:H" & lr)
'Set RngH = ws.Range("H1:H" & lr)
With ws
   
    For i = lr To 1 Step -1
    If InStr((Cells(i, 8)), "Total") = 11 Then GoTo Skip
            With Rng
                .AutoFilter
                'MsgBox Range("H" & (i)).Value
                .AutoFilter Field:=8, Criteria1:=Cells(i, "H").Value
                   'lrs = .SpecialCells(xlCellTypeVisible).Rows.Count
                .SpecialCells(xlCellTypeVisible).Copy
                wsn = Cells(i, "H").Value
                Sheets.Add(After:=Sheets(Sheets.Count)).name = Cells(i, "H").Value
                ActiveSheet.Paste
                ttl = 0
                lrs = Sheets(wsn).Cells(Rows.Count, "H").End(xlUp).Row
                For j = lrs To 2 Step -1
                    Set Rngs = Range("F2:F" & lrs)
                    ttl = WorksheetFunction.Sum(Rngs)
                    If ttl = 0 Then
                        'ws.Cells(i, "I").EntireRow.Delete
                        ws.Cells(i, "I").Value = "Del"
                        'MsgBox ttl
                    End If
                Next j
               
                        Application.DisplayAlerts = False
                            ThisWorkbook.Sheets(wsn).Delete
                        Application.DisplayAlerts = True
            End With
Skip:
    Next i
    ' Turn off filter
    ws.AutoFilterMode = False
   
For u = lr To 1 Step -1
    If ws.Cells(u, "I").Value = "Del" Or (ws.Cells(u, "F").Value = 0 _
    And Right(ws.Cells(u, "H").Value, 5) = "Total") And _
    ws.Cells(u, "H").Value <> "Grand Total" Then
        ws.Cells(u, "I").EntireRow.Delete
    End If
Next u
ws.Activate
End With

Application.ScreenUpdating = True
End Sub

Hey ManiacB. Thanks so much for your code as well. I've tried this one out as well and works perfectly. Always good to have more than one option