Myujth

Example Transaction Set:

Note the 3 transactions shown. The two transactions highlighted in green are the ones I'd like to delete or flag (doesn't matter).

Using VBA, the code is way too clunky. The code takes forever to run because

1. I loop through each transaction in column C until I find a negative.


2. Set Column E as the absolute value target if not zero, else absolute value D.


3. Define the range for a specific account so that I can begin looping through it to find value in step 2.


4. If I find the value, I delete both rows (one containing negative and the one which isn't a negative).

My apologies for not commenting code. This was not 100% done yet.

Sub ReversalScrub()

Dim AccountNumber As String
Dim TargetAmount As Double
Dim TargetRange As Range
Dim Transactions As Range
Dim Transaction As Variant
Dim DeletionCount As Integer

 Set RawTransactions = Worksheets("RawTransactions")

 With RawTransactions
 Set Transactions = .Range("C1", .Range("C2").End(xlDown))

 End With

 TransactionRow = 2

 Do Until TransactionRow = Transactions.Rows.Count

 If Range("C" & TransactionRow).Value < 0 Then

 If Range("C" & TransactionRow).Offset(0, 2).Value < 0 Then

 TargetAmount = Abs(Range("C" & TransactionRow).Offset(0, 2).Value)
 Else
 TargetAmount = Abs(Range("C" & TransactionRow).Offset(0, 1).Value)
 End If

 AccountNumber = Range("C" & TransactionRow).Offset(0, -2).Value

 Set TargetRange = GetAccountRange(AccountNumber, RawTransactions)

 CurrentRow = TargetRange.Row

 Do Until CurrentRow = TargetRange.Rows.Count - 1
 If (TargetAmount = Range("E" & CurrentRow).Value Or TargetAmount = Range("D" & CurrentRow).Value) Then
 Range("A" & CurrentRow).EntireRow.Delete
 Range("C" & TransactionRow).EntireRow.Delete
 CurrentRow = CurrentRow - 2
 Exit Do

 End If
 CurrentRow = CurrentRow + 1
 Loop
 End If
 TransactionRow = TransactionRow + 1
 Loop

End Sub

So then I decided to write a function to see if it would be faster.

1. Column F: Check if the transaction is negative. If so, create a key using account number, abs(column D), abs(column E). =IF((C91<0),A91&ABS(D91)&ABS(E91))
   


2. Column G: Create a key account number, column D, Column E. =A91&D91&E91
   


3. Column H: Check whether column F exists within G using Match. =IFERROR(MATCH(F91,$G$1:G91,0),FALSE)
   


4. Column I: Check whether actual cell row, matches that of column H from step. =IFERROR(MATCH(ROW(H91),H:H,0),FALSE)
   


5. Column J: Check whether H or I are number (MATCH output), if so, they are flagged as reversals and the user can delete them.
   =IF(OR(ISNUMBER(H91),ISNUMBER(I91)),"Reversal",IF(C91=0,"Zero",""))
   

The problem is that this, too, crashes my computer. How can I effectively find duplicates and remove them without removing the third row?

Second solution sample:

This seems to work with a small data set. Try it and adjust as needed. I'm flagging cell F with a reversal message.

This looks through column C until it finds an empty cell. If you have empty cells you will need to adjust the Do Until loop.

I am skipping cells that have been flagged previously (not empty cell F)

Note it will only flag 1 cell as matching.

Sub FlagReversals()

Dim MyExit As String
Dim PosLoc
Dim NegLoc
Dim NegAmt
Dim PosAmt

Range("C2").Select

 Do Until IsEmpty(ActiveCell)
 If ActiveCell.Value < 0 And IsEmpty(ActiveCell.Offset(0, 3).Value) Then
 NegLoc = ActiveCell.Address
 Acct = ActiveCell.Offset(0, -2)
 NegAmt = ActiveCell.Value
 PosAmt = Abs(ActiveCell.Value)
 MyExit = "False"
 Do Until MyExit = "True"
 If ActiveCell.Offset(-1, 0).Row > 1 Then
 ActiveCell.Offset(-1, 0).Select
 Else
 Range(NegLoc).Select
 ActiveCell.Offset(1, 0).Select
 MyExit = "True"
 End If
 If Acct = ActiveCell.Offset(0, -2) And IsEmpty(ActiveCell.Offset(0, 3).Value) And MyExit = "False" Then
 If PosAmt = ActiveCell.Value Then
 ' found the match (by account and value)
 ActiveCell.Offset(0, 3).Value = "Reversal from address " & NegLoc
 PosLoc = ActiveCell.Address
 Range(NegLoc).Select
 ActiveCell.Offset(0, 3).Value = "Reversal from address " & PosLoc
 MyExit = "True"
 End If
 End If
 Loop
 End If
 ActiveCell.Offset(1, 0).Select
 Loop

End Sub

Edit: Cleaned up infinite loop when no match found.