Delete Rows in Subtotal Groups if Subtotal is Zero

NicNac123

New Member
Joined
Oct 3, 2020
Messages
6
Office Version
  1. 2016
Platform
  1. Windows
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.
 

Attachments

  • Subtotal Zero Deletion test.JPG
    Subtotal Zero Deletion test.JPG
    79.7 KB · Views: 17

Some videos you may like

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,472
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.

VBA Code:
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

New Member
Joined
Oct 3, 2020
Messages
6
Office Version
  1. 2016
Platform
  1. Windows
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.

VBA Code:
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 :)
 

NicNac123

New Member
Joined
Oct 3, 2020
Messages
6
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

 

ManiacB

Board Regular
Joined
Aug 11, 2020
Messages
56
Office Version
  1. 365
Platform
  1. Windows
Here is another approach, solved it too late but someone might be interested

VBA Code:
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

New Member
Joined
Oct 3, 2020
Messages
6
Office Version
  1. 2016
Platform
  1. Windows
Here is another approach, solved it too late but someone might be interested

VBA Code:
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 :)
 

Watch MrExcel Video

Forum statistics

Threads
1,128,207
Messages
5,629,294
Members
416,384
Latest member
frsamiee

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