查找，剪切和插入行以匹配VBA Excel中的借方和贷方值
我在Sheet1中有以下设置数据，并从第4行A列开始，其中第3行的标题为：
No Date Code Name Remarks D ebit Cr edit 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 ebit Cr edit 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中没有任何返回。 我打算这样做，使用数组和查找function，因为数据集的大小是非常大的，但如何使用工作表不能这样做？ 有人可以帮我吗？
好的抱歉，如果我在这里违反规定
我要解决这个问题的方法是将我的数据值设置为一个数组，然后将借记金额设置为一个variables，并通过数据集循环查找是否有任何信用与variables借记金额相匹配 – 我会组织下一个匹配到他们的借记，然后通过组织arrays一点清洁剂，并将结果粘贴到表单中。
我会好奇的尝试更多的数据，但是：
'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
好吧 – 改变了一下 – 我不确定我们现在是否需要在最后的情况下数组下移，因为主循环j循环内的退出，但它的工作方式是 – 没有花费很多更多的时间，我会让你玩它。 使用断点和你的本地窗口/ debug.assert来看看它在做什么。 希望这可以帮助
这似乎更容易与辅助函数sorting。 例如
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
我不能尝试代码，但只是为了显示这个想法（假设数据在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
起色
好的，最后我find了自己的方法来解决这个问题。 对不起，如果需要时间太长。 我也要感谢克莱德和斯莱伊给我的答案。 对此，我真的非常感激。
而不是削减整行匹配的数据，然后将其插入到它的行对下面这被认为是耗时的，我分配相同的值的匹配对（我称这些数字为ID匹配）基于匹配的顺序，然后删除 （分配vbNullString ）的匹配对，以便他们不会再次通过循环数组处理。 我还将内循环的起点从i = 1为j = i+1因为下一个要处理的订单位于数据之下，因为它的下一个候选匹配不会在其上方find。 在所有的数据被标记为连续的数字之后，我根据列ID匹配（列I）按升序对所有数据进行sorting。 为了提高代码性能，我将列F＆G中的数据复制到一个数组中，我使用.Value2而不是Excel的默认设置，因为它只取值范围而不使用其格式（借记和贷项以会计数字格式） 。 这是我用来实现这个任务的代码：
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
它完成的任务平均less于2.75秒 （两倍更快，比编辑版本短得多），用于在我的机器上处理大约11,000行。 看到下面的post的细节。