Macro for removing reversal entries

[yogyata26]

Hi

I want a macro which would remove the entries if there is a debit and credit of the same amount (column 'E') of the same customer (column 'B') of the same document type (column 'C') on the same date (column 'D').

I have highlighted one such example in yellow (Row 114 & 115).

Debits are amounts in positive and credits are in negatives.

Thanks in advance!

https://drive.google.com/open?id=13j...19SATfOS3xK1fh

[Marc L]

Hi !

Attach a workbook with a crystal clear explanation …

[yogyata26]

Hi

So basically, if Columns B, C and D of two rows matches and the amount column ( column E) corresponding to those two rows has a positive amount for one entry and negative amount for another entry then those two rows has to be removed.

I have attached a simpler worksheet in which the rows marked in yellow are the rows to be removed.

Can you please help me with a macro to do this job?

Thanks!

[Marc L]

So basically according to your attachment a demonstration as a beginner starter :

Sub Demo()
   Const F = "=B1&""#""&C1&""#""&D1&""#"""
     Dim C&, L&, R&, T%(), E, V, W, X
         C = -1
         Application.ScreenUpdating = False
    With [A1].CurrentRegion.Columns
         L = .Rows.Count
         ReDim T(1 To L, 0)
         E = .Item(5).Value2
        .Item(6).Formula = F
         V = .Item(6).Value2
        .Item(6).Formula = F & "&E1"
         W = .Item(6).Value2
     For R = 2 To L - 1
         If T(R, 0) = 0 Then
            X = Application.Match(V(R, 1) & -E(R, 1), W, 0)
            If IsNumeric(X) Then If T(X, 0) = 0 Then T(R, 0) = 1: T(X, 0) = 1: C = C + 2
         End If
     Next
     If C > 0 Then
        .Item(6).Value2 = T
        .Resize(, 6).Sort Cells(1, 6), xlAscending, Header:=xlYes
        .Rows(L - C & ":" & L).Clear
     End If
        .Item(6).Clear
    End With
         Application.ScreenUpdating = True
End Sub 

Do you like it ? So thanks to click on bottom left star icon « ★ Add Reputation » !

[yogyata26]

Hi,

Thank you for this awesome code.

But, this macro does not delete all the reversals in a sheet.
If the number of line items is more it deletes only a few. So I have to run the macro again and again.

Can you help me edit this code so that the macro would repeat its task until all the reversals are deleted?

Thanks in advance.

[yogyata26]

Thanks a lot!

Can you please explain the code?

[Marc L]

Except for Match which is an Excel worksheet function (so to see in Excel help) all is yet in the VBA inner help ‼
So place the text cursor on a statement and hit the F1 key then just read, that's it !
Easy as I just followed a child logic like any beginner can apply.
To summarize : an helper column is used for a concatenation formula in order to mark the rows to clear …

[yogyata26]

Thank you!

[jindon]

If duplicates match from the order of appearance.

Sub test()
    Dim a, i As Long, ii As Long, txt As String, w, x As Range
    With Range("b1", Range("b" & Rows.Count).End(xlUp)).Resize(, 4)
        a = .Value
        With CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(a, 1)
                txt = Join(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
                If a(i, 4) > 0 Then
                    If Not .exists(txt) Then
                        Set .Item(txt) = CreateObject("System.Collections.ArrayList")
                    End If
                    .Item(txt).Add Array(a(i, 4), i)
                ElseIf (.exists(txt)) * (a(i, 4) < 0) Then
                    If .Item(txt).Count Then
                        For ii = 0 To .Item(txt).Count - 1
                            If a(i, 4) = .Item(txt)(ii)(0) * -1 Then
                                If x Is Nothing Then
                                    Set x = Union(Rows(i), Rows(.Item(txt)(ii)(1)))
                                Else
                                    Set x = Union(x, Rows(i), Rows(.Item(txt)(ii)(1)))
                                End If
                                .Item(txt).RemoveAt ii
                                If .Item(txt).Count = 0 Then .Remove txt
                                Exit For
                            End If
                        Next
                    End If
                End If
            Next
        End With
        If Not x Is Nothing Then x.EntireRow.Delete
    End With
End Sub

[yogyata26]

Hi,

It is showing an error!Error.png

[jindon]

Change to

Sub test()
    Dim a, e, i As Long, txt As String, w, x As Range
    With Range("b1", Range("b" & Rows.Count).End(xlUp)).Resize(, 4)
        a = .Value
        With CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(a, 1)
                txt = Join(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
                If a(i, 4) > 0 Then
                    If Not .exists(txt) Then
                        Set .Item(txt) = CreateObject("Scripting.Dictionary")
                    End If
                    .Item(txt)(i) = a(i, 4)
                ElseIf (.exists(txt)) * (a(i, 4) < 0) Then
                    If .Item(txt).Count Then
                        For Each e In .Item(txt).keys
                            If a(i, 4) = .Item(txt)(e) * -1 Then
                                If x Is Nothing Then
                                    Set x = Union(Rows(i), Rows(e))
                                Else
                                    Set x = Union(x, Rows(i), Rows(e))
                                End If
                                .Item(txt).Remove e
                                If .Item(txt).Count = 0 Then .Remove txt
                                Exit For
                            End If
                        Next
                    End If
                End If
            Next
        End With
        If Not x Is Nothing Then x.EntireRow.Delete
    End With
End Sub

[yogyata26]

Hi,

Although it is working in the sample sheet, it's not working in my attached sheet.

Could you please help me with this?


https://finadvantagecoin478-my.share...ke1Pw?e=WdkUkP

[jindon]

You should upload your workbook here.
If it is too big, zip it, or just enough rows of data that shows how you want it.

Shutdown my pc already, so I wil look at it tomorrow.

[yogyata26]

I had attached the link to my workbook in my previous reply.
Attaching the link here again.

For your understanding, row no. 106 and 107 have to be removed (just an example).

Thank you!

https://drive.google.com/file/d/1ufY...ew?usp=sharing

[jindon]

Sub test()
    Dim a, e, i As Long, ii As Long, txt As String, flg As Boolean, x As Range
    With Range("a1", Cells.SpecialCells(11))
        a = .Value
        With CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(a, 1)
                txt = Join(Array(a(i, 2), a(i, 3), a(i, 4)), Chr(2))
                If Len(txt) < 3 Then Exit For
                If Not .exists(txt) Then
                    Set .Item(txt) = CreateObject("Scripting.Dictionary")
                    .Item(txt)(i) = a(i, 5)
                Else
                    If .Item(txt).Count Then
                        For Each e In .Item(txt).keys
                            If a(i, 5) = .Item(txt)(e) * -1 Then
                                flg = True: Exit For
                            End If
                        Next
                    End If
                    If flg Then
                        If x Is Nothing Then
                            Set x = Union(Rows(i), Rows(e))
                        Else
                            Set x = Union(x, Rows(i), Rows(e))
                        End If
                        .Item(txt).Remove e
                    Else
                        .Item(txt)(i) = a(i, 5)
                    End If
                    flg = False
                End If
            Next
        End With
    End With
    If Not x Is Nothing Then
        x.EntireRow.Delete
    Else
        MsgBox "No matched data"
    End If
End Sub

[yogyata26]

Works flawlessly!

Thank you.