VBA 按 Doc# 和金额匹配并移动银行对账记录
支付小周
结论
不需要设置多个 Do Loop，也不要在查找匹配项时立即删除行。可以按下面的方式处理：
- 使用两层循环。外层定位当前记录，内层从下一行开始查找候选记录。
- 用布尔数组标记已匹配的行，防止同一条记录被重复使用。
- 找完所有匹配项后，再统一高亮、复制，并从底部向上删除。
- 通过参数选择匹配规则，可以要求 Doc# 和金额同时匹配，也可以只按金额匹配。
这样可以避免删除操作改变行号，也不需要再写第二个 Macro。
完整代码
以下代码假定：
"Pending Items"是待匹配工作表。"Compensated Items"是目标工作表。- 第 2 行是标题，第 3 行开始是数据。
- Doc# 位于 E 列。
- Amount 位于 G 列。
- Adjustment 位于 J 列。
- Amount 单元格中保存的是 Excel 数值，而不是文本。
Option Explicit
Private Const SOURCE_SHEET As String = "Pending Items"
Private Const TARGET_SHEET As String = "Compensated Items"
Private Const HEADER_ROW As Long = 2
Private Const FIRST_DATA_ROW As Long = 3
Private Const DOC_COLUMN As Long = 5 'E
Private Const AMOUNT_COLUMN As Long = 7 'G
Private Const ADJUSTMENT_COLUMN As Long = 10 'J
Public Sub MatchByDocAndAmount()
'Doc# 相同，并且金额合计为零
MatchAndMoveCompensatedItems True
End Sub
Public Sub MatchByAmountOnly()
'忽略 Doc#，只检查金额是否相互抵销
MatchAndMoveCompensatedItems False
End Sub
Private Sub MatchAndMoveCompensatedItems(ByVal RequireSameDoc As Boolean)
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim matched() As Boolean
Dim lastRow As Long
Dim targetRow As Long
Dim currentRow As Long
Dim candidateRow As Long
Dim movedCount As Long
Dim currentAmount As Currency
Dim candidateAmount As Currency
Dim currentDoc As String
Dim candidateDoc As String
Dim isMatch As Boolean
Dim previousCalculation As XlCalculation
On Error GoTo CleanFail
Set sourceSheet = ThisWorkbook.Worksheets(SOURCE_SHEET)
Set targetSheet = ThisWorkbook.Worksheets(TARGET_SHEET)
lastRow = sourceSheet.Cells( _
sourceSheet.Rows.Count, AMOUNT_COLUMN).End(xlUp).Row
If lastRow < FIRST_DATA_ROW Then
MsgBox "Pending Items 中没有可处理的数据。", _
vbInformation, "Bank Reconciliation"
Exit Sub
End If
ReDim matched(FIRST_DATA_ROW To lastRow)
previousCalculation = Application.Calculation
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'第一阶段：查找匹配项，不删除任何行。
For currentRow = FIRST_DATA_ROW To lastRow - 1
If Not matched(currentRow) Then
If IsNumeric(sourceSheet.Cells(currentRow, AMOUNT_COLUMN).Value) Then
currentAmount = CCur( _
sourceSheet.Cells(currentRow, AMOUNT_COLUMN).Value)
currentDoc = Trim$(CStr( _
sourceSheet.Cells(currentRow, DOC_COLUMN).Value))
'从当前记录的下一行重新开始查找。
For candidateRow = currentRow + 1 To lastRow
If Not matched(candidateRow) Then
If IsNumeric(sourceSheet.Cells( _
candidateRow, AMOUNT_COLUMN).Value) Then
candidateAmount = CCur(sourceSheet.Cells( _
candidateRow, AMOUNT_COLUMN).Value)
candidateDoc = Trim$(CStr(sourceSheet.Cells( _
candidateRow, DOC_COLUMN).Value))
isMatch = (currentAmount <> 0@) _
And (currentAmount + candidateAmount = 0@)
If RequireSameDoc Then
isMatch = isMatch _
And (Len(currentDoc) > 0) _
And (StrComp( _
currentDoc, _
candidateDoc, _
vbTextCompare) = 0)
End If
If isMatch Then
matched(currentRow) = True
matched(candidateRow) = True
Exit For
End If
End If
End If
Next candidateRow
End If
End If
Next currentRow
'目标表下一条可写入记录。
targetRow = targetSheet.Cells( _
targetSheet.Rows.Count, 1).End(xlUp).Row + 1
If targetRow <= HEADER_ROW Then
targetRow = FIRST_DATA_ROW
End If
'第二阶段：高亮并按原始顺序复制到目标表。
For currentRow = FIRST_DATA_ROW To lastRow
If matched(currentRow) Then
With sourceSheet
.Range(.Cells(currentRow, 1), _
.Cells(currentRow, ADJUSTMENT_COLUMN)) _
.Interior.Color = RGB(173, 216, 230)
.Cells(currentRow, ADJUSTMENT_COLUMN).Value = "Compensated"
.Range(.Cells(currentRow, 1), _
.Cells(currentRow, ADJUSTMENT_COLUMN)).Copy _
Destination:=targetSheet.Cells(targetRow, 1)
End With
targetRow = targetRow + 1
movedCount = movedCount + 1
End If
Next currentRow
'第三阶段：必须从底部向上删除，避免行号移动。
For currentRow = lastRow To FIRST_DATA_ROW Step -1
If matched(currentRow) Then
sourceSheet.Rows(currentRow).Delete
End If
Next currentRow
CleanExit:
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = previousCalculation
If Err.Number = 0 Then
MsgBox movedCount & " 条记录已移动，组成 " & _
movedCount \ 2 & " 组匹配。", _
vbInformation, "Bank Reconciliation"
End If
Exit Sub
CleanFail:
Dim errorNumber As Long
Dim errorDescription As String
errorNumber = Err.Number
errorDescription = Err.Description
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = previousCalculation
MsgBox "处理失败：" & errorDescription, _
vbExclamation, "Bank Reconciliation"
End Sub如何运行
需要同时匹配 Doc# 和 Amount 时，运行：
MatchByDocAndAmount只检查 Amount 是否相互抵销时，运行：
MatchByAmountOnly例如，严格模式会匹配：
Doc# 991893 Amount 3000000
Doc# 991893 Amount -3000000
但不会匹配：
Doc# 991893 Amount 3000000
Doc# 888888 Amount -3000000
金额模式则会匹配以上两种情况。
原来的循环为什么容易失效
原代码有以下问题：
positive和negative分别被重复声明为Currency和Long。启用Option Explicit后，代码无法通过编译。- 外层 Macro 和第二个 Macro 都会把
m、o重新设为固定值，循环状态无法正常延续。 - 查找过程中直接删除行，会改变后续记录的行号。
- 代码使用了
Select、Selection和ActiveSheet，执行结果取决于当前激活的工作表和选区。 LastRow根据 F 列计算，但实际数据范围应由 Amount 所在的 G 列确定。- 从 G 列执行
Offset(0, 2)会指向 I 列，而题目中的 Adjustment 位于 J 列。 - 固定范围
A2:N25无法处理第 25 行之后的数据。 - 先按颜色筛选再复制，可能会把以前着色的其他记录一并复制。
两层 For 循环已经处理了候选记录到达最后一行的情况。内层循环结束后，外层循环会把 currentRow 移到下一行，新的 candidateRow 再从 currentRow + 1 开始。
关于 Type 的处理
当前代码不限制 D 列中的 Type，因此只要满足匹配条件，以下组合都可以处理：
Payment与Bank DebitReceivable与Bank Credit
如果业务规则要求限制允许的 Type 组合，可以添加下面的检查函数：
Private Function IsAllowedTypePair( _
ByVal firstType As String, _
ByVal secondType As String) As Boolean
firstType = LCase$(Trim$(firstType))
secondType = LCase$(Trim$(secondType))
IsAllowedTypePair = _
(firstType = "payment" And secondType = "bank debit") _
Or _
(firstType = "bank debit" And secondType = "payment") _
Or _
(firstType = "receivable" And secondType = "bank credit") _
Or _
(firstType = "bank credit" And secondType = "receivable")
End Function完成金额和 Doc# 判断后，再追加以下代码：
isMatch = isMatch And IsAllowedTypePair( _
CStr(sourceSheet.Cells(currentRow, 4).Value), _
CStr(sourceSheet.Cells(candidateRow, 4).Value))注意事项
3.000.000,00和(3.000.000,00)必须是 Excel 能识别的数值。如果导入后被保存为文本，IsNumeric可能返回False，需要先转换数据。- 代码使用
Currency处理常见财务金额，可以避免大多数二进制浮点精度问题。Currency的小数精度为 4 位。如果金额超出它的取值范围，需要改用其他数值处理方式。 - 当前匹配策略是一对一，从上到下查找，找到第一个匹配项后立即停止。如果同一金额出现多次，配对结果会受数据顺序影响。
- 代码不会匹配金额都为零的两条记录，因此保留了
currentAmount <> 0@条件。 - 只按金额匹配可能出现误配，尤其是在包含大量重复金额的对账表中。可以先按 Doc# 严格匹配，再对剩余记录按金额匹配并进行人工复核。
- 如果目标工作表的实际名称仍是
"Compensated"，需要修改TARGET_SHEET常量，使它与工作簿中的名称完全一致。
备注：内容仅供参考。