Find, cut, and insert row to match the value of debit and credit in VBA Excel

Question

I have the following set data in Sheet1 and start from row 4 column A where the header in row 3:

No  Date        Code              Name      Remarks   D e b i t   Cr e d i t
1   4/30/2015   004/AB/01/04/15   Anna      YES       40239.66    0.00
2   2/16/2015   028/AA/01/02/15   Andy      NO        0.00        2205.49
3   1/31/2015   021/DR/04/01/15   Jim       YES       167.60      0.00
4   7/14/2015   083/RF/01/07/15   Anna      YES       3822.60     0.00
5   8/6/2015    030/AB/01/08/15   Anna      NO        0.00        11267.96
6   1/15/2015   020/TY/01/01/15   Barry               0.00        5237.84
7   7/14/2015   024/HU/01/07/15   Anna      NO        0.00        3822.60
8   1/31/2015   039/JK/01/01/15             YES       0.00        1780.84
9   1/27/2015   007/ER/01/01/15   Jim       NO        5237.84     0.00
10  4/29/2015   077/FX/01/04/15   Barry     NO        0.00        40239.66
11  1/3/2015    001/OX/10/01/15   Andy      NO        33074.03    0.00
12  8/10/2015   001/PR/01/08/15   Nicholas            11267.96    0.00
13  10/31/2015  007/TX/09/10/15   Jim                 1780.84     0.00
14  2/28/2015   071/QR/01/02/15   Andy      YES       2205.49     0.00
15  1/7/2015    007/OM/02/01/15   Nicholas            8873.25     0.00

And I need to arrange the data above in the same sheet based on the value of debit and credit in no particular order as long as the values of debit and credit: x and y are followed by the values of debit and credit: y and x (preferably x > y) where the unmatched data will be put in the bottom of arranged table. For example something like this :

No  Date        Code              Name      Remarks   D e b i t   Cr e d i t
14  2/28/2015   071/QR/01/02/15   Andy      YES       2205.49     0.00
2   2/16/2015   028/AA/01/02/15   Andy      NO        0.00        2205.49
4   7/14/2015   083/RF/01/07/15   Anna      YES       3822.60     0.00
7   7/14/2015   024/HU/01/07/15   Anna      NO        0.00        3822.60
12  8/10/2015   001/PR/01/08/15   Nicholas            11267.96    0.00
5   8/6/2015    030/AB/01/08/15   Anna      NO        0.00        11267.96
9   1/27/2015   007/ER/01/01/15   Jim       NO        5237.84     0.00
6   1/15/2015   020/TY/01/01/15   Barry               0.00        5237.84
13  10/31/2015  007/TX/09/10/15   Jim                 1780.84     0.00
8   1/31/2015   039/JK/01/01/15             YES       0.00        1780.84
1   4/30/2015   004/AB/01/04/15   Anna      YES       40239.66    0.00
10  4/29/2015   077/FX/01/04/15   Barry     NO        0.00        40239.66
11  1/3/2015    001/OX/10/01/15   Andy      NO        33074.03    0.00
15  1/7/2015    007/OM/02/01/15   Nicholas            8873.25     0.00
3   1/31/2015   021/DR/04/01/15   Jim       YES       167.60      0.00

Honestly, I couldn't come up with the right code to do this and it's really driving me crazy. This is one of my failed attempts, I've tried something like this

Sub MatchingDebitAndCredit()
Dim i As Long, j As Long, Last_Row As Long
Last_Row = Cells(Rows.Count, "F").End(xlUp).Row

For i = 4 To Last_Row
For j = 4 To Last_Row
    If Cells(i, "F").Value = Cells(j, "G").Value And Cells(i, "G").Value = Cells(j, "F").Value Then
    Rows(i).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
    Rows(j).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
    Exit For
    End If
Next j
Next i
End Sub

I copied the matched data in Sheet2 since I was not able to do it the same sheet but it was failed, nothing returned in Sheet2 after the program completed. I intend to do this using arrays and the Find function since the size of data set is very large but how come I could do that if using worksheet can't? Could someone here help me out, please?

So if multiple credits match a debit what would you want to happen? — Clyde, Jul 21 '16 at 14:10
I found this question very similar to your previous question. If you have the ID Match column, sort the column will solve yr problem ? — Eric K., Jul 24 '16 at 03:34
@EricK. Yup! You read my mind on how I handle that problem. I used this way instead of cutting and inserting the entire matched data since it's way much faster. Hahaha — Anastasiya-Romanova 秀, Jul 24 '16 at 09:51

Clyde · Answer 1 · 2016-07-22T13:41:48.250

okay sorry if I break the rules here

The way I'd tackle this is to set my data values into an array then set debit amount into a variable, and loop back through the data set to find out if any credits match the variable debit amount - I'd organize the matches next to their debits then go through and organize the array a little cleaner and paste the result into the sheet.

I would be curious to try this out on more data but :

'constants declared for column numbers within array
Const lDEBITCOL As Long = 6
Const lCREDITCOL As Long = 7

Dim rA                                          'main array
Dim iMain&, stackRow&                           'module long variables
Dim debitAmt#                                   'module double variable

Sub raPairMain()

Dim j&

rA = ActiveSheet.UsedRange                      'setting activesheet into array

For iMain = 2 To UBound(rA)                     'imain loop through ra rows
    debitAmt = rA(iMain, lDEBITCOL)             'variable to check through credits in j loop
    'efficiency logical comparison for 0 values in debit amount
    'debit amount is 0 skip j loop
    If debitAmt Then

        For j = 2 To UBound(rA)                 'j loop through ra rows
            If debitAmt Then                    'necessary for matches on the last line of data
            'matching variable to credit amount in array
                If debitAmt = rA(j, lCREDITCOL) Then

                    'function to shift down rows within array
                    'first parameter(imain) is destination index
                    'second parameter is index to insert
                    'imain +1 to insert under current debit amount
                    shiftRaRowDown iMain + 1, j

                    Exit For
                End If                              'end of match for debit amount
            End If
        Next j                                  'increment j loop
    End If                                      'end of efficiency logical comparison
Next iMain                                      'increment imain loop

OrganizeArray                                   'procedure to stack array by matches

'setup array2 for dropping into worksheet to keep headings
'to preserve the table structure if present
ReDim rA2(UBound(rA) - 2, UBound(rA, 2) - 1)
Dim i&
For i = 2 To UBound(rA)
    For j = LBound(rA, 2) To UBound(rA, 2)
        rA2(i - 2, j - 1) = rA(i, j)
    Next j
Next i

'drop array2 into worksheet with offset
With ActiveSheet
    .Range(.Cells(2, 1), .Cells(UBound(rA), UBound(rA, 2))) = rA2
End With

End Sub

Sub OrganizeArray()
stackRow = 2                                    'initiate top row for stacking based on column headings
                                                'could also just constantly use row 2 and shift everything down
Dim i&, j&                                      'sub procedure long variables
Dim creditAmt#                                  'sub procedure double variable
    For i = 2 To UBound(rA)                     'initiate loop through ra rows
        debitAmt = rA(i, lDEBITCOL)             'set variable to find
        'efficiency check to bypass check if debit amount is null
        If debitAmt Then
            If i + 1 < UBound(rA) Then          'logical comparison for last array index
                'determine if next line is equal to variable debit amt
                If debitAmt = rA(i + 1, lCREDITCOL) Then
                    shiftRaRowDown stackRow, i  'insert in array position stack row as variable next top row
                    stackRow = stackRow + 1     'increment stack row based on new top row
                    'noted in primary procedure
                    shiftRaRowDown stackRow, i + 1
                    stackRow = stackRow + 1     'increment stack row for new top of array
                End If                          'end comparison for variable debit amount
            End If                              'end comparison for upper boundary of ra
        End If                                  'end comparison for null debit value
    Next i                                      'increment i loop
End Sub


Sub shiftRaRowDown(ByVal destinationIndex As Long, ByVal insertRow As Long)
    Dim i&, j&                                  'sub primary long variables for loop
    'for anytime the destination matches the insertion row exit sub procedure
    If destinationIndex = insertRow Then Exit Sub

    'if the destination row for debit was found after the credit amount
    'call the procedure again reversing the inputs and offsetting
    'debit / credit hierarchy
    If destinationIndex > insertRow Then
        shiftRaRowDown insertRow, destinationIndex - 1
        Select Case iMain
            Case Is < UBound(rA) - 1
                iMain = iMain + 1                      'increment main sub procedure i
            'reset debit amount to new main i value if it is within the array boundary
            Case Is <= UBound(rA)
                debitAmt = rA(iMain, lDEBITCOL)
            Case Else
                debitAmt = 0                        'necessary for matches on the last line of data
        End Select
        Exit Sub                                'exit recursive stack
    End If

    'get boundaries for a temporary storage array for row to insert
    ReDim tmparray(UBound(rA, 2))

    'function below will place data from array to move into temporary array
    tmparray = RowToInsert(insertRow)

    'initiate loop from the array copied temporary array back to the
    'row where it is being inserted
    For i = insertRow To destinationIndex Step -1

        'loop through columns to replace values
        For j = LBound(rA, 2) To UBound(rA, 2)
            rA(i, j) = rA(i - 1, j)             'values from previous row i-1 are set
        Next j
    Next i

    'loop through  temporary array to place copied temporary data
    For i = LBound(rA, 2) To UBound(rA, 2)

        'temporary array is single dimension
        rA(destinationIndex, i) = tmparray(i - 1)

    Next i
End Sub

Function RowToInsert(ByVal arrayIndex As Long) As Variant
    ReDim tmp(UBound(rA, 2) - 1)                'declare tempArray with boundaries offset for 0 address
    Dim i&                                      'sub procedure long iterator

    If arrayIndex > UBound(rA) Then
        RowToInsert = tmp
        Exit Function
    End If

    For i = LBound(tmp) To UBound(tmp)          'loop to store temporary values from array
        tmp(i) = rA(arrayIndex, i + 1)
    Next i
    RowToInsert = tmp                           'setting function = temporary array
End Function

okay - changed it a bit - I'm not sure we need the case at the end now within the array shift down because of the exit for within the primary paring j loop, but it works the way it is - without spending a whole lot more time on it i'll let you play around with it. use breakpoints and your locals window / debug.assert to see what it's doing. Hope this helps

Thanks for the answer. Can I ask one thing, could you make the program to take the first credit of multiple credits that it finds and put the rest at the bottom? (+1) — Anastasiya-Romanova 秀, Jul 22 '16 at 02:27
If the rest at the bottom, I can move them to other sheet then run your program again and put them back. Though it's not efficient way but clearly your program make it faster and more easy. I really appreciate it. :) — Anastasiya-Romanova 秀, Jul 22 '16 at 02:33
of course - I was attempting to give you ideas - I would really do some thorough vetting prior to implementing it for any clients - it has some gaps still for improvements. perhaps one of the more experienced forum users would have better input :) I'm curious to see how a "good" programmer would attack this — Clyde, Jul 22 '16 at 13:46
Finally, I found a way to do this task and I've posted an [answer](http://stackoverflow.com/a/38564419/3397819) to my own question. Once again, thanks for your help :) — Anastasiya-Romanova 秀, Jul 25 '16 at 09:48

score 1 · Answer 2 · answered Jul 24 '16 at 00:10

This seems easier to just sort with helper functions. For example

No  Date        Code            Name    Remarks Debit       Credit      match   sum
13  10/31/2015  007/TX/09/10/15 Jim             1,780.84    0.00        -1      1,780.84
8   1/31/2015   039/JK/01/01/15         YES     0.00        1,780.84    -1      1,780.84
14  2/28/2015   071/QR/01/02/15 Andy    YES     2,205.49    0.00        -1      2,205.49
2   2/16/2015   028/AA/01/02/15 Andy    NO      0.00        2,205.49    -1      2,205.49
4   7/14/2015   083/RF/01/07/15 Anna    YES     3,822.60    0.00        -1      3,822.60
7   7/14/2015   024/HU/01/07/15 Anna    NO      0.00        3,822.60    -1      3,822.60
9   1/27/2015   007/ER/01/01/15 Jim     NO      5,237.84    0.00        -1      5,237.84
6   1/15/2015   020/TY/01/01/15 Barry           0.00        5,237.84    -1      5,237.84
12  8/10/2015   001/PR/01/08/15 Nicholas        11,267.96   0.00        -1      11,267.96
5   8/6/2015    030/AB/01/08/15 Anna    NO      0.00        11,267.96   -1      11,267.96
1   4/30/2015   004/AB/01/04/15 Anna    YES     40,239.66   0.00        -1      40,239.66
10  4/29/2015   077/FX/01/04/15 Barry   NO      0.00        40,239.66   -1      40,239.66
3   1/31/2015   021/DR/04/01/15 Jim     YES     167.60      0.00        0       167.60
15  1/7/2015    007/OM/02/01/15 Nicholas        8,873.25    0.00        0       8,873.25
11  1/3/2015    001/OX/10/01/15 Andy    NO      33,074.03   0.00        0       33,074.03

I can't try the code, but just to show the idea (assuming the data is in Sheet2!A1:G16)

Sub MatchingDebitAndCredit()
    With Worksheets("Sheet2").Range("A2:I16")  ' exclude the headers row and include the columns for the helper functions

        .Columns("H").Formula = "= CountIf( $F:$F, $G2 ) * -( $G2 > $F2 ) + CountIf( $G:$G, $F2 ) * -( $F2 > $G2 ) " ' you can probably simplify this formula or combine it with the other one
        .Columns("I").Formula = "= $F2 + $G2 "

        .Sort key1:=.Range("H1"), key2:=.Range("I1"), key3:=.Range("G1")  ' sort by match, then by sum, and then by Credit (or adjust to your preference with Record Macro)

        .Columns("H:I").Clear ' optional to clear the helper functions
    End With
End Sub

Your code works well for my example data but it doesn't if there are duplicate data. Thanks for your answer. FWIW, I've found the method to solve this problem. (+1) — Anastasiya-Romanova 秀, Jul 24 '16 at 10:06

score 0 · Accepted Answer · edited May 23 '17 at 11:59

Improvement

OK, finally I found my own way to solve this problem. Sorry if it takes time too long. I also want to thank Clyde and Slai for the answers they gave me. I really appreciate it.

Instead of cutting the entire row of matched data and then inserting it below the row of its pair which is considered time-consuming, I assign the same values to the matched pair (I called these numbers as ID Match) based on the order of matching, then delete (assign vbNullString) the matched pair so that they won't be processed again via looping through array. I also set the starting point of the inner loop from i = 1 to j = i+1 because the next order to be processed is located below the data since its next candidate matched won't be found above it. After all the data have been labelled the consecutive numbers, I sort all data in ascending order based on the column ID Match (Column I). To improve the code performance, I copy the data in column F & G to an array and I use .Value2 rather than Excel's default setting because it only takes the values of the range without its format (Debit and Credit are in Accounting number format). Here is the code I use to implement this task:

Sub Quick_Match()
Dim i As Long, j As Long, k As Long, Last_Row As Long
Dim DC, Row_Data, ID_Match
Last_Row = Cells(Rows.Count, "A").End(xlUp).Row
ReDim DC(1 To Last_Row - 1, 1 To 2)
ReDim Row_Data(1 To Last_Row - 1, 1 To 1)
ReDim ID_Match(1 To Last_Row - 1, 1 To 1)
DC = Range("A2:B" & Last_Row).Value2

For i = 1 To Last_Row - 2
    If DC(i, 1) <> vbNullString Then
            k = k + 1
            For j = i + 1 To Last_Row - 1
            If DC(j, 2) <> vbNullString Then
                If DC(i, 1) = DC(j, 2) And DC(i, 2) = DC(j, 1) Then
                    Row_Data(i, 1) = j + 1: ID_Match(i, 1) = k
                    Row_Data(j, 1) = i + 1: ID_Match(j, 1) = k
                    DC(i, 1) = vbNullString: DC(i, 2) = vbNullString
                    DC(j, 1) = vbNullString: DC(j, 2) = vbNullString
                    Exit For
                End If
            End If
            Next j
    End If

    If Row_Data(i, 1) = vbNullString Then
        Row_Data(i, 1) = "No Match": k = k - 1
    End If
Next i

Range("C2:C" & Last_Row) = Row_Data
Range("D2:D" & Last_Row) = ID_Match
Columns("A:D").Sort key1:=Range("D2"), order1:=xlAscending, Header:=xlYes
End Sub

It completes the task less than 2.75 seconds on average (twice faster and much shorter than before edited version) for processing roughly 11,000 rows on my machine. See the following post for the detail.

great job :) looks really clean too. – Clyde Jul 25 '16 at 14:48 — Clyde, Jul 25 '16 at 14:48

Find, cut, and insert row to match the value of debit and credit in VBA Excel

3 Answers3

Linked