VBA - macro checking if sum of several rows = 0 and deleting rows

[maxon]

Hi All,

I need a help with following problem. I have a table with client accounts and movements.
I need a tool, which will be checking rows and recognise if sum of all movements for the same client aro equal to 0.
If yes, client should be deleted, if not should go next.

Client Stat USD
Client1 20 -221.42
Client1 20 221.42
Client2 30 287.87
Client2 20 -349.56
Client2 30 -287.87
Client2 20 349.56
Client2 30 291.55
Client2 20 -354.02
Client2 30 -291.55
Client2 20 354.02
Client3 30 683.61
Client3 20 -830.10
Client3 30 -683.61
Client3 20 830.10
Client4 30 170.34
Client4 20 -206.84
Client4 30 -170.34
Client4 20 206.54

As you can see, clients from 1 to 3 should be deleted, 4 need to be checked manually by user.

Thank you in advance!
Max

 

[Trebor76]

Hi maxon,

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

Option Explicit
Sub Macro1()
    
    Dim lngMyCol As Long, _
        lngMyRow 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
    lngMyRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    With Columns(lngMyCol)
        With Range(Cells(2, lngMyCol), Cells(lngMyRow, lngMyCol))
            .Formula = "=IF(SUMIFS($C$2:$C$" & lngMyRow & ",$A$2:$A$" & lngMyRow & ",A2)=0,NA(),"""")"
            '=IF(SUMIFS($C$2:$C$19,$A$2:$A$19,A2)=0,NA(),"")
            ActiveSheet.Calculate
            .Value = .Value
        End With
        .Replace "DEL", "#N/A", xlWhole
        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 "Process complete"

End Sub

I've made the assumption that Client, Stat and USD are in columns A, B and C (respectively) and that the data starts from Row 2.

Regards,

Robert

 

[maxon]

Thanks Robert, may you explain a little bit your code for me, step by step, I would like to learn something from that lesson

 

[Trebor76]

Hi maxon,

Here's the code annotated:

Option Explicit
Sub Macro1()
    
    '//Declare varaibles//
    Dim lngMyCol As Long, _
        lngMyRow As Long
    Dim xlnCalcMethod As XlCalculation
            
    With Application
        xlnCalcMethod = .Calculation 'Grab current calculation method
        .Calculation = xlCalculationManual 'Set the calculation method to manual for faster processing
        .ScreenUpdating = False 'Turn screen updating off for most efficient processing
    End With

    lngMyCol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1 'Find the last column used in the tab and increment it by one.  This will be our 'helper' column.
    lngMyRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 'Find the last row used in the tab.
    
    With Columns(lngMyCol)
        With Range(Cells(2, lngMyCol), Cells(lngMyRow, lngMyCol)) 'Set the range
            'Enter the formula '=IF(SUMIFS($C$2:$C$19,$A$2:$A$19,A2)=0,NA(),"") (if the last row was 19) in our helper column
            .Formula = "=IF(SUMIFS($C$2:$C$" & lngMyRow & ",$A$2:$A$" & lngMyRow & ",A2)=0,NA(),"""")"
            ActiveSheet.Calculate 'Calculate the tab
            .Value = .Value 'Convert formulas in helper column to values
        End With
        On Error Resume Next 'Turn error reporting off - OK to ignore 'No cells found' message
            .SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete 'Delete all visible cells in error (#N/A)
        On Error GoTo 0 'Turn error reporting back on
        .Delete
    End With
    
    With Application
        .Calculation = xlnCalcMethod 'Set the calculation method to what it was originally
        .ScreenUpdating = True 'Turn screen updating back on
    End With

    MsgBox "Process complete" 'Inform the user the macro has run

End Sub

Note as the code doesn't loop and the way the calculation method is set to manual during processing it's very fast.

HTH

Robert

 

[maxon]

Thanks Trebor76,

I noticed one error, when I had following situation :
[TABLE="width: 144"]
<colgroup><col></colgroup><tbody>[TR]
[TD="align: right"]-371.79[/TD]
[/TR]
[TR]
[TD="align: right"]371.48[/TD]
[/TR]
[TR]
[TD="align: right"]0.31[/TD]
[/TR]
</tbody>[/TABLE]
tool present it as something is wrong, but when I put the formula manually it was 0.
I had to do small modification, I deleted IF before SUMIFS and changed number format of column where SUMFIFS is calculating and afther that I deleteing all 0 values and now its working perfectly!

THanks for your support once again!

 

[Trebor76]

NP. At a guess I'd say it's to do with rounding but if you've found a solution that's great

 

[maxon]

Yes, I had no idea before that about SUMIFS option in Excel

I have code as below:

Dim lngMyCol As Long, lngMyRow As Long
Dim xlnCalcMethod As XlCalculation
        
With Application
    xlnCalcMethod = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

lngMyCol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
lngMyRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

With Columns(lngMyCol)
    With Range(Cells(2, lngMyCol), Cells(lngMyRow, lngMyCol))
        .Formula = "=SUMIFS($H$2:$H$" & lngMyRow & ",$F$2:$F$" & lngMyRow & ",F2)"
        ActiveSheet.Calculate
        .Value = .Value
        .NumberFormat = "0.00"
    End With
End With
    
If WorksheetFunction.CountIf(ws.Range(Cells(2, lngMyCol), Cells(lngMyRow, lngMyCol)), "=0") > 0 Then
    With ws.Range("A1").CurrentRegion
        .AutoFilter Field:=lngMyCol, Criteria1:="=0.00"
        .Offset(1, 0).Resize(ws.Range("A1").CurrentRegion.Rows.Count - 1).Rows.Delete
    End With
    ws.AutoFilterMode = False
End If
   
With Application
    .Calculation = xlnCalcMethod
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

MsgBox "Process complete"

Anyway, thanks again!