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.
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?
So basically according to your attachment a demonstration as a beginner starter :
PHP Code:
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 » !
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?
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 …
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
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
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
Bookmarks