Option Explicit
Sub WhyDoItManually()
'
' constants
Const ksWS = "Sheet3"
Const klMin As Long = 250000
'
' declarations
Dim lMin As Long, iCol As Integer, lFrom As Long, lTo As Long, lPos As Long
Dim rng As Range, cel As Range
Dim sCel As String
Dim I As Integer
'
' start
' subtotal column
Worksheets(ksWS).Activate
Range("A1").Select
On Error Resume Next
Cells.Find(What:="Subtotal", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
On Error GoTo 0
If ActiveCell.Address = "$A$1" Then Exit Sub
Set cel = ActiveCell
iCol = cel.Column
lPos = 1
' range
Set rng = Columns(iCol)
' minimum
lMin = CLng(Val(InputBox("Enter the min value to remove groups", "Min value", klMin)))
If lMin = 0 Then lMin = klMin
'
' process
Do
' position
lFrom = cel.Row
' control
If cel.Value < lMin Then
' subtotal formula
sCel = cel.Formula
' subtotal range
I = InStr(sCel, ",")
Set rng = Range(Mid(sCel, I + 1, Len(sCel) - I - 1))
With rng
lFrom = .Row
lTo = .Row + .Rows.Count
' remove
Range(Rows(lFrom), Rows(lTo)).Delete xlShiftUp
' reposition
Cells(lFrom - 1, iCol).Select
lPos = lFrom - 1
End With
End If
' next group
On Error Resume Next
Cells.Find(What:="Subtotal", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
If Err.Number > 0 Then Exit Do
On Error GoTo 0
Set cel = ActiveCell
Loop Until cel.Row < lPos
'
' end
Set rng = Nothing
Beep
'
End Sub