VBA to delete lines that add up to zero

[granty]

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

 

[Trebor76]

Hi granty,

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

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]

Trebor76,

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

Change the following line of code:

  With Range(Cells(1, lngMyCol), Cells(lngLastRow, lngMyCol))

To this:

  With Range(Cells(lngStartRow, lngMyCol), Cells(lngLastRow, lngMyCol))

 

[Trebor76]

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]

Trebor76,

You are very welcome.

Nice solution - one for my archives.

 

[Trebor76]

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]

hi granty,

you might also try this

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]

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

 

[hiker95]

Cross posted here:
VBA to delete lines that add up to zero

A message to forum cross posters.

Please read this:
Excelguru Help Site - A message to forum cross posters