• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Macro to delete rows when subtotal is equal to a certain value

Bomino

Member
Hello,
I've been trying to resolve this all day without success. I've been googling too without success; and I thought most likely someone would help me here.
I would like to delete the subtotal line and the associated rows when subtotal equals a certain value.

Thank you.
 
Hi, NARAYANKA991

Please see attached sample data. Obviously my file has more 100K records.

If subtotal is less than 250,000 then delete subtotal along with all associated rows.

Thank you.
 

Attachments

  • SampleData.xlsx
    31.1 KB · Views: 5
Hi ,

Do you really need a macro ?

I can describe the manual procedure to do this , and it should not take you more than a few minutes to get it done.

Narayan
 
Hi, Bomino!

Give a look at the uploaded file.

This is the code:
Code:
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

Regards!
 

Attachments

  • SampleData.xlsm
    39 KB · Views: 12
Hi SirBJ7,

I tested your code and I noticed that the code will execute even if I click Cancel. Am I missing something?

Your help is very much appreciated.
 
Hi, Bomino!
If you click Cancel you don't modify the default value, 250K. Change its setting to 0 won't remove anything but it'll run indeed. To avoid the execution when clicking Cancel change the default value to 0 and place an if after the input box assignation to perform an exit sub.
Regards!
 
Hi, Bomino!
Hope you could solve it.
If no, just tell us. If yes, thanks for your feedback and welcome back whenever needed or wanted.
Regards!
 
Hi, Bomino!
Hope you could solve it.
If no, just tell us. If yes, thanks for your feedback and welcome back whenever needed or wanted.
Regards!

Hi, SirJB7

Sorry, I was out for couple of days; I didn't get to tweak your code yet. is it something you could do, please ?

Regards.
 
Hi, Bomino!
If I didn't understand you incorrectly there was nothing to change to the code, is it?
Regards1
 
Hi, Bomino!
Just replace this sentence:
Code:
    If lMin = 0 Then lMin = klMin
by this one:
Code:
    If lMin = 0 Then Exit Sub
Regards!
 
Back
Top