使用VBA实现银行对账中多笔借贷金额净额归零组合的匹配与高亮

我们公司和关联方存在大量交易（销售、贷方、借方等），但极少实际付款。偶尔需要识别**正负金额净额归零（或差额极小可直接核销）**的交易组合，以此减少未结项并完成核销。

当前操作是将未结项导出到Excel，手动排序后寻找接近零的组合，但从未找到完全归零的情况。我的核心目标是最小化未结项数量：

• 优先选择组合后净额尽可能接近零的（小额差额可直接核销）
• 同一净额下，优先包含更多交易的组合（比如+1、+2、+2与-5的四笔组合，比+5与-5的两笔组合更优）

现有VBA代码仅能识别单笔正负匹配的组合（如+5和-5），需要修改代码实现多笔组合的识别与高亮。

现有代码 #

Sub sum_groups()
Dim CurrentCell As Range, CurrentRange As Range, rg As Range
Dim LastRow As Long
Dim ColorIndex As Long

LastRow = ActiveSheet.UsedRange.Rows.Count
ColorIndex = 6

Set CurrentCell = ActiveSheet.Range("A2")
Set CurrentRange = CurrentCell

'Loop until end of list
Do Until CurrentCell.Row = LastRow

    'Loop until 0 group is found
    Do Until WorksheetFunction.sum(CurrentRange) = 0
        'Break loop if last row is reached
        If CurrentCell.Row + CurrentRange.Rows.Count > LastRow Then Exit Do
        Set CurrentRange = CurrentRange.Resize(CurrentRange.Rows.Count + 1)
    Loop
    
    If WorksheetFunction.sum(CurrentRange) = 0 Then
        'Alternate color
        If ColorIndex = 6 Then
            ColorIndex = 4
        ElseIf ColorIndex = 4 Then
            ColorIndex = 6
        End If
        
        'Enter 0 and change color
        For Each rg In CurrentRange
            rg.Interior.ColorIndex = ColorIndex
            rg.Offset(0, 1) = 0
        Next rg
        
        'Move to next cell after current range
        Set CurrentCell = CurrentCell.Offset(CurrentRange.Rows.Count)
    Else
        'Move to next cell after current tested cell
        Set CurrentCell = CurrentCell.Offset(1)
    End If
    
    'Reset CurrentRange
    Set CurrentRange = CurrentCell

Loop

End Sub

修改后的代码（支持多笔组合识别） #

代码逻辑说明 #

• 引入差额容忍度（可自行调整Tolerance值），允许组合净额在容忍范围内即视为可核销
• 采用回溯算法遍历所有可能的交易组合，优先选择交易数量最多、净额最接近零的组合
• 标记已处理的交易，避免重复匹配
• 交替颜色高亮不同组合，便于区分

Sub FindOptimalZeroSumGroups()
    Dim ws As Worksheet
    Dim amounts() As Double
    Dim used() As Boolean
    Dim lastRow As Long, i As Long, j As Long
    Dim tolerance As Double
    Dim bestCombination As Collection
    Dim bestSum As Double, bestCount As Integer
    Dim colorIndex As Integer
    
    ' 设置参数
    Set ws = ActiveSheet
    tolerance = 0.01 ' 可调整的差额容忍度，比如0.01代表允许±0.01的差额
    colorIndex = 6 ' 初始高亮颜色（黄色）
    
    ' 获取数据范围（假设金额在A列，从A2开始）
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    If lastRow < 2 Then Exit Sub ' 无数据则退出
    
    ' 初始化数组
    ReDim amounts(1 To lastRow - 1)
    ReDim used(1 To lastRow - 1)
    For i = 1 To lastRow - 1
        amounts(i) = ws.Cells(i + 1, "A").Value
        used(i) = False
    Next i
    
    ' 遍历所有未处理的交易
    For i = 1 To lastRow - 1
        If Not used(i) Then
            ' 重置最佳组合
            Set bestCombination = New Collection
            bestSum = amounts(i)
            bestCount = 1
            bestCombination.Add i
            
            ' 调用回溯函数寻找最优组合
            Call FindBestCombination(amounts, used, i, amounts(i), 1, bestSum, bestCount, bestCombination, tolerance)
            
            ' 如果找到符合条件的组合
            If Abs(bestSum) <= tolerance Then
                ' 高亮组合并标记已处理
                For Each j In bestCombination
                    used(j) = True
                    ws.Cells(j + 1, "A").Interior.ColorIndex = colorIndex
                    ws.Cells(j + 1, "B").Value = 0 ' 标记为已核销
                Next j
                
                ' 交替颜色
                colorIndex = IIf(colorIndex = 6, 4, 6)
            End If
        End If
    Next i
End Sub

Private Sub FindBestCombination(amounts() As Double, used() As Boolean, currentIndex As Integer, _
                               currentSum As Double, currentCount As Integer, _
                               ByRef bestSum As Double, ByRef bestCount As Integer, _
                               ByRef bestCombination As Collection, tolerance As Double)
    Dim i As Integer
    Dim tempSum As Double
    
    ' 检查当前组合是否更优：要么差额更小，要么差额相同但交易数量更多
    If Abs(currentSum) < Abs(bestSum) Or _
       (Abs(currentSum) = Abs(bestSum) And currentCount > bestCount) Then
        bestSum = currentSum
        bestCount = currentCount
        ' 更新最佳组合
        Set bestCombination = New Collection
        For i = 1 To UBound(used)
            If i <= currentIndex And used(i) Then
                bestCombination.Add i
            End If
        Next i
        bestCombination.Add currentIndex
    End If
    
    ' 遍历后续未处理的交易，尝试加入组合
    For i = currentIndex + 1 To UBound(amounts)
        If Not used(i) Then
            used(i) = True
            tempSum = currentSum + amounts(i)
            
            ' 递归寻找更优组合
            Call FindBestCombination(amounts, used, i, tempSum, currentCount + 1, _
                                     bestSum, bestCount, bestCombination, tolerance)
            
            used(i) = False ' 回溯，取消标记
        End If
    Next i
End Sub

使用说明 #

1. 将金额数据放在Excel的A列，从A2开始（A1可放表头）
2. 打开VBA编辑器（Alt+F11），插入新模块，粘贴上述代码
3. 根据业务需求调整tolerance值（比如设置为0.1，允许±0.1的差额）
4. 运行FindOptimalZeroSumGroups宏，代码会自动识别最优组合并高亮，同时在B列标记0表示已核销

注意事项 #

• 数据量较大时（比如超过100行），回溯算法可能会变慢，可先筛选出金额绝对值较小的交易优先组合，减少计算量
• 若需要完全匹配零净额，将tolerance设置为0即可，但实际业务中可能很难找到完全匹配的组合

内容的提问来源于stack exchange，提问作者Ajit Kumar Jena