查找、剪切和插入行以匹配 VBA Excel 中借方和贷方的值
Find, cut, and insert row to match the value of debit and credit in VBA Excel
我在 Sheet1 中设置了以下数据，从第 4 行第 A 列开始，其中第 3 行的 header：
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
而且我需要根据借方和贷方的价值将上面的数据 安排在相同的 sheet 中，只要借方的价值不分先后和贷方：x 和 y 后面是借方和贷方的值：y 和 x（最好是x > y），其中不匹配的数据会放在排列好的table的底部。例如 像这样 :
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 中复制了匹配的数据，因为我无法做到同样的事情 sheet 但它失败了，程序完成后 Sheet2 中没有任何返回。我打算使用数组和 Find 函数来执行此操作，因为数据集的大小非常大，但如果使用 worksheet 不能，我怎么能这样做呢？请问有人能帮帮我吗？
好的，如果我违反了这里的规则，对不起
我解决这个问题的方法是将我的数据值设置到一个数组中，然后将借方金额设置到一个变量中，然后循环返回数据集以找出是否有任何贷方与可变借方金额匹配 - 我' d 在他们的借方旁边组织匹配项，然后仔细组织数组并将结果粘贴到 sheet.
我很想在更多数据上尝试一下，但是 :
'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 循环中退出 for，但它的工作方式是 -不用花太多时间在上面我会让你玩弄它。使用断点和你的本地人 window / debug.assert 来查看它在做什么。希望这有帮助
使用辅助函数进行排序似乎更容易。例如
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
改善
好的，我终于找到了自己的方法来解决这个问题。对不起，如果时间太长。我还要感谢 and 他们给我的答案。非常感谢。
我没有切割整行匹配数据然后将其插入到其对的行下方，这被认为是耗时的，我将相同的值分配给匹配对（我将这些数字称为 ID 匹配）基于按照匹配的顺序，然后删除（分配vbNullString）匹配的对，这样它们就不会通过遍历数组再次处理。我还将内部循环的起点从 i = 1 设置为 j = i+1，因为下一个要处理的订单位于数据下方，因为它的下一个匹配候选不会在其上方找到。在所有数据都被标记为连续数字后，我根据列 ID 匹配（列 I）按升序对所有数据进行排序。为了提高代码性能，我将 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
在我的机器上处理大约 11,000 行，它平均在 2.75 秒 内完成任务（比编辑前的版本快两倍，也短得多）。详情请参阅 。
我在 Sheet1 中设置了以下数据，从第 4 行第 A 列开始，其中第 3 行的 header：
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
而且我需要根据借方和贷方的价值将上面的数据 安排在相同的 sheet 中，只要借方的价值不分先后和贷方：x 和 y 后面是借方和贷方的值：y 和 x（最好是x > y），其中不匹配的数据会放在排列好的table的底部。例如 像这样 :
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 中复制了匹配的数据，因为我无法做到同样的事情 sheet 但它失败了，程序完成后 Sheet2 中没有任何返回。我打算使用数组和 Find 函数来执行此操作，因为数据集的大小非常大，但如果使用 worksheet 不能，我怎么能这样做呢？请问有人能帮帮我吗？
好的，如果我违反了这里的规则，对不起
我解决这个问题的方法是将我的数据值设置到一个数组中，然后将借方金额设置到一个变量中，然后循环返回数据集以找出是否有任何贷方与可变借方金额匹配 - 我' d 在他们的借方旁边组织匹配项，然后仔细组织数组并将结果粘贴到 sheet.
我很想在更多数据上尝试一下，但是 :
'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 循环中退出 for，但它的工作方式是 -不用花太多时间在上面我会让你玩弄它。使用断点和你的本地人 window / debug.assert 来查看它在做什么。希望这有帮助
使用辅助函数进行排序似乎更容易。例如
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
改善
好的，我终于找到了自己的方法来解决这个问题。对不起，如果时间太长。我还要感谢
我没有切割整行匹配数据然后将其插入到其对的行下方，这被认为是耗时的，我将相同的值分配给匹配对（我将这些数字称为 ID 匹配）基于按照匹配的顺序，然后删除（分配vbNullString）匹配的对，这样它们就不会通过遍历数组再次处理。我还将内部循环的起点从 i = 1 设置为 j = i+1，因为下一个要处理的订单位于数据下方，因为它的下一个匹配候选不会在其上方找到。在所有数据都被标记为连续数字后，我根据列 ID 匹配（列 I）按升序对所有数据进行排序。为了提高代码性能，我将 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
在我的机器上处理大约 11,000 行，它平均在 2.75 秒 内完成任务（比编辑前的版本快两倍，也短得多）。详情请参阅