Remove unwanted sum data cources

[KLund1]

I have some sample data below. (3 columns, but shows here as data, space, store number, space, amt) It is excel subtotaled by store number. I need to delete all a store's rows that have a subtotal less 1000. in VBA (ignore date info, real data will have only 1 date)
for example store 5 has a subtotal of 45.63. I need to delete the 38.05, 7.58. and I think the subtotal '5 Total 45.63' line. and loop through all the subtotal and test each. The number of rows per store will always vary. This is an interim step in much longer process, but I'm stuck on this part.
Hope I'm clear. Suggestions? Thanks


Date Store Number Amt Sold
10/9/2011 3 184.01
10/16/2011 3 869.99
10/17/2011 3 869.99
10/9/2011 3 24.89
10/16/2011 3 43.29
3 Total 1992.17
10/9/2011 5 38.05
10/16/2011 5 7.58
5 Total 45.63
10/16/2011 6 43.39
10/9/2011 6 113.37
10/9/2011 6 6.82
6 Total 163.58
10/9/2011 7 66.77
10/9/2011 7 53.86
10/9/2011 7 24.77
7 Total 145.4
10/9/2011 8 108.71
10/9/2011 8 184.86
10/16/2011 8 10.86
8 Total 304.43
10/9/2011 9 46.54
10/9/2011 9 48.7
10/9/2011 9 1353.1
9 Total 1448.34
10/16/2011 10 1210.43
10/9/2011 10 1777.83
10/9/2011 10 26.93
10/9/2011 10 118.51
10 Total 3133.7
10/16/2011 11 38.05
10/9/2011 11 77.73
10/16/2011 11 128.09
10/9/2011 11 7.6
10/9/2011 11 978.74
10/16/2011 11 7.6
10/9/2011 11 14.13
10/9/2011 11 304.49
10/9/2011 11 58.7
10/16/2011 11 52.19
10/9/2011 11 13.03
10/9/2011 11 48.93
10/16/2011 11 10.84
10/9/2011 11 103.3
11 Total 1843.42

 

[drsarao]

Try this:

Sub KillUnderAchievers()
With ActiveSheet 'put the sheet name here if needed
    lr = .Cells(Rows.Count, 1).End(xlUp).Row 'last row of data
    sr = 2 'start row for a store
    For r = 2 To lr
        If .Cells(r, "B") = "Total" Then  'presume the "Total" is in column B (change if needed)
            If .Cells(r, "C") <= 1000 Then
                dr = r - sr 'row(s) to delete
                .Cells(r, "A").Offset(-dr, 1).Resize(dr + 1).EntireRow.Delete
                r = r - dr 'subtract deleted rows
                lr = lr - dr 'reduce lr too
                sr = r 'new start row for a store
            Else
                sr = r + 1 'new start row for a store
            End If
        End If
    Next r
End With
End Sub

 

[KLund1]

drsarao Thanks a lot!!
Nice code, worked perfectly.
People like you are why this site works!!!
Better than Google!!
Thanks

 

[drsarao]

You are welcome.

 

[Rick Rothstein]

Well, I developed it, so I guess I'll show it to you ... here is another macro that should do what you asked for...

Sub DeleteUnderperformingStores()
  Dim Totals As Range, Cell As Range, LastTotal As Range
  Application.ScreenUpdating = True
  With Columns("B")
    .Replace "Total", "=Total", xlWhole
    .Value = .Value
    Set Totals = .SpecialCells(xlConstants, xlErrors)
    .Replace "=", "", xlPart
  End With
  Set LastTotal = Range("B1")
  For Each Cell In Totals
    If Cell.Offset(, 1).Value < 1000 Then Range(LastTotal.Offset(1), Cell).Formula = "=""X"""
    Set LastTotal = Cell
  Next
  Columns("B").SpecialCells(xlFormulas).EntireRow.Delete
  Application.ScreenUpdating = True
End Sub

 

[KLund1]

Rick Rothstein, well, thank you too.
Code works good also.

This is what the internet was designed for, collaboration on a project.!!!!