Bdtyktl

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.