VBA to delete lines that add up to zero

granty

Board Regular
Joined
Jul 28, 2005
Messages
117
Hi,

I am looking for a vba code which searches a table for items with same reference, adds of the corresponding amounts . if it adds to zero, delete the items from the table. see below example

Ref amount
a102 50
b156 25
a102 -50
a568 12
a578 10

So, i will like to search and delete lines 1 and 3 as they add up to zero.

Thank you
 

Some videos you may like

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,714
Hi granty,

Try the following (initially on a copy of your data as the results cannot be undone if they're not as expected):

Code:
Option Explicit
Sub Macro2()

    Const lngStartRow As Long = 2 'Starting row number for your data. Change to suit.
    
    Dim lngMyCol As Long, _
        lngLastRow As Long
    Dim xlnCalcMethod As XlCalculation
            
    With Application
        xlnCalcMethod = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    lngMyCol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    lngLastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    With Columns(lngMyCol)
        With Range(Cells(1, lngMyCol), Cells(lngLastRow, lngMyCol))
            'The following formula assumes the items are in Col. A and their associated amounts are in Col. B. Change to suit.
            .Formula = "=IF(SUMIF($A$" & lngStartRow & ":$A$" & lngLastRow & ",A" & lngStartRow & ",$B$" & lngStartRow & ":$B$" & lngLastRow & ")=0,NA(),"""")"
            ActiveSheet.Calculate
            .Value = .Value
        End With
        On Error Resume Next 'Turn error reporting off - OK to ignore 'No cells found' message
            .SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
        On Error GoTo 0 'Turn error reporting back on
        .Delete
    End With
    
    With Application
        .Calculation = xlnCalcMethod
        .ScreenUpdating = True
    End With

    MsgBox "All rows where the total of each item in Col. A adds to zero from the amounts in Col. B have now been deleted.", vbInformation

End Sub

Any code line that you may need to change for your actual data I've marked with the comment 'Change to suit.'

Regards,

Robert
 

hiker95

Well-known Member
Joined
Apr 8, 2009
Messages
17,649
Trebor76,

Very nice solution, but, you will have to adjust one line of code.

Change the following line of code:

Rich (BB code):
  With Range(Cells(1, lngMyCol), Cells(lngLastRow, lngMyCol))


To this:

Rich (BB code):
  With Range(Cells(lngStartRow, lngMyCol), Cells(lngLastRow, lngMyCol))
 

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,714
Code:
Very nice solution, but, you will have to adjust one line of code.

Hi hiker95,

Thanks for the kind feedback and well spotted :)

Cheers,

Robert
 

hiker95

Well-known Member
Joined
Apr 8, 2009
Messages
17,649

ADVERTISEMENT

Trebor76,

You are very welcome.

Nice solution - one for my archives. (y)
 

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,714
Gee, that is a big complement!!

I'm glad you thought so highly of it and that you let me know that you did ;)

Take care,

Robert
 

kalak

Active Member
Joined
Jun 10, 2015
Messages
487

ADVERTISEMENT

hi granty,

you might also try this
Code:
Sub del_sumtozero()

Dim i As Long
Dim a As Variant
Dim dic As Object

Set dic = CreateObject("scripting.dictionary")
a = Range("A1").CurrentRegion

For i = 1 To UBound(a)
    dic(a(i, 1)) = dic(a(i, 1)) + a(i, 2)
Next i

For i = UBound(a) To 1 Step -1
    If dic(a(i, 1)) = 0 Then Range("A" & i).Resize(, 2).Delete xlUp
Next i

End Sub
 

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,714
granty,

If you must cross-post please provide a link to the other forum(s) as I have with this link as it will save time for others trying to provide you with a solution (like I have) when you've already received a solution here. So annoying!!

Robert
 

Watch MrExcel Video

Forum statistics

Threads
1,122,521
Messages
5,596,653
Members
414,083
Latest member
Mrsash

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