查找，剪切和插入行以匹配VBA Excel中的借方和信用额度 [英] Find, cut, and insert row to match the value of debit and credit in VBA Excel
问题描述
我在Sheet1中有以下设置数据，从第4列开始，第3列中的标题：
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
我需要在同一个表格中安排上方的数据 x 和 y 之间的借方和贷方的金额没有特殊的顺序，则扣除借方和贷方的值后面： y 和 x （最好是 x> y ），其中不匹配的数据将放在排列表的底部。例如 这样的 ：
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
我复制了Sheet2中的匹配数据，因为我无法做同样的工作表，但是失败了，在程序完成后没有返回到Sheet2。我打算使用数组和Find函数，因为数据集的大小非常大，但是如果使用工作表不能这样做，我该怎么办？有人可以帮助我吗？
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?
推荐答案
改进
好的，终于我找到了自己的方法来解决这个问题。对不起，如果需要时间太长。我还要感谢克莱德和 Slai 他们给我的答案。我真的很感激。
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.
而不是切割整个匹配的数据行，然后将其插入到它对的行之下，这被认为是耗时的，我分配相同的匹配对的值（我将这些数字称为ID匹配）根据匹配顺序，然后删除（分配 vbNullString ）匹配对以便它们不会通过循环通过数组再次被处理。我还将内部循环的起始点从 i = 1 设置为 j = i + 1 ，因为下一个订单被处理的位于数据下方，因为它的下一个候选人匹配将不会在其上方找到。在所有数据被标记为连续数字之后，我将按照列ID匹配（第一列）按升序对所有数据进行排序。为了提高代码性能，我将数据复制到F& G到数组，我使用 .Value2 ，而不是Excel的默认设置，因为它只采用范围的值没有格式（借记和信用是会计数字格式）。以下是我用于实现此任务的代码：
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
它完成的任务小于 2.75秒平均（比编辑版本快两倍，短得多）for processi在我的机器上大约有11,000行。有关详细信息，请参阅 以下帖子 。
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.
这篇关于查找，剪切和插入行以匹配VBA Excel中的借方和信用额度的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
