查找、剪切和插入行以匹配VBA Excel中借方和贷方的值

我在Sheet1中有以下设置数据，从第4行A列开始，其中第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

我需要在同一张表中根据借贷价值安排上述数据，只要借贷价值：x和y紧跟借贷价值：y和x（最好x>y）其中不匹配的数据将放在排列表的底部。例如像这样的东西：

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

老实说，我不能想出正确的代码来做这件事，这真的让我发疯。这是我失败的尝试之一，我尝试过类似的事情

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

---

我在Sheet2中复制了匹配的数据，因为我无法在同一张表中执行此操作，但失败了，程序完成后，Sheet2中没有返回任何内容。我打算使用数组和Find函数来实现这一点，因为数据集的大小非常大，但是如果使用工作表不能实现，我怎么能做到呢？这里有人能帮我一下吗？

好的，如果我违反了这里的规则，很抱歉

我解决这个问题的方法是将我的数据值设置为一个数组，然后将借记金额设置为一个变量，然后循环返回数据集，以确定是否有任何贷项与可变借记金额匹配——我会将匹配项组织在它们的借记项旁边，然后再将数组组织得更清晰一些，并将结果粘贴到工作表中

我很想在更多数据上尝试一下，但是：

'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

为数组中的列编号声明的常量 常量lDEBITCOL的长度=6 Const lCREDITCOL的长度=7 Dim rA'主阵列 Dim iMain和stackRow模块长变量 Dim debitAmt#'模块双变量 副拉帕梅因（） Dim j& rA=ActiveSheet.UsedRange'将ActiveSheet设置为数组 对于iMain=2到UBound（rA）'iMain通过rA行循环 debitAmt=rA（iMain，lDEBITCOL）'变量，用于检查j循环中的积分 '借方金额中0值的效率逻辑比较 '借方金额为0跳过j循环 如果借记则 对于j=2到UBound（rA）'j循环通过rA行 如果debitAmt，则最后一行数据的匹配需要' '将变量与数组中的贷方金额匹配 如果debitAmt=rA（j，lCREDITCOL），则 '函数在数组中下移行 '第一个参数（imain）是目标索引 '第二个参数是要插入的索引 '要在当前借方金额下插入的imain+1 移位向下移动iMain+1，j 退出 如果“借方金额匹配结束”，则结束 如果结束 下一个j'增量j循环 “如果结束”效率逻辑比较结束 下一个iMain'增量iMain循环 OrganizerRay按匹配项堆叠数组的过程 '设置用于放入工作表以保留标题的array2 '以保留表结构（如果存在） 重播rA2（UBound（rA）-2，UBound（rA，2）-1） 昏暗的我& 对于i=2至UBound（rA） 对于j=LBound（rA，2）到UBound（rA，2） rA2（i-2，j-1）=rA（i，j） 下一个j 接下来我 '将阵列2放入具有偏移量的工作表中 使用ActiveSheet .Range（.Cells（2，1），.Cells（UBound（rA），UBound（rA，2））=rA2 以 端接头 附属机构 stackRow=2'根据列标题启动顶部行进行堆叠 “也可以经常使用第2行，并将所有内容向下移动 Dim i&，j&'子过程长变量 Dim creditAmt#子过程双变量 对于i=2到UBound（rA）'通过rA行启动循环 debitAmt=rA（i，lDEBITCOL）'设置要查找的变量 '如果借方金额为空，则跳过效率检查 如果借记则 如果i+1insertRow，则 移位向下插入行，目标索引-1 选择Case-iMain 病例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

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

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