【Excel VBA编程】数字寻宝:一堆明细中快速凑出目标数字

Sub 凑单发货()    ' 定义变量    Dim TargetQty As Long    Dim InventoryArr As Variant, BatchArr As Variant    Dim i As Long, j As Long    Dim BestSum As Long, CurrentSum As Long    Dim BestDict As Object, TempDict As Object    Dim wsSource As Worksheet    Dim Key As Variant    Dim DataRow As Long    ' 设置工作表:当前活动工作表    Set wsSource = ActiveSheet    ' 设置目标发货量    TargetQty = wsSource.Range("D2").Value ' 取自D2单元格的值    ' 获取批次数据（A列）和库存数据（B列）    With wsSource        Dim LastRow As Long        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row        InventoryArr = .Range("B2:B" & LastRow).Value        BatchArr = .Range("A2:A" & LastRow).Value    End With    ' 初始化最佳字典    BestSum = 0    Set BestDict = CreateObject("Scripting.Dictionary")    ' 核心算法：顺序遍历寻找最佳组合    For i = 1 To UBound(InventoryArr, 1)        CurrentSum = 0        Set TempDict = CreateObject("Scripting.Dictionary")        For j = i To UBound(InventoryArr, 1)            If CurrentSum + InventoryArr(j, 1) <= TargetQty Then                CurrentSum = CurrentSum + InventoryArr(j, 1)                TempDict(BatchArr(j, 1)) = InventoryArr(j, 1)                '检查是否找到更优解 (更接近目标)                If CurrentSum > BestSum Then                    BestSum = CurrentSum                    BestDict.RemoveAll                    For Each Key In TempDict.Keys                        BestDict(Key) = TempDict(Key)                    Next Key                End If                ''如果恰好等于目标，则为最优解，提前退出                If CurrentSum = TargetQty Then                    BestSum = CurrentSum                    BestDict.RemoveAll                    For Each Key In TempDict.Keys                        BestDict(Key) = TempDict(Key)                    Next Key                    Exit For                End If            End If        Next j        Set TempDict = Nothing        If BestSum = TargetQty Then Exit For     Next i    '清除可能存在的旧颜色标记    wsSource.Range("A2:B" & LastRow).Interior.Color = xlNone    ' 将最佳组合中的批次所在行标记为蓝色    For DataRow = 2 To LastRow ' 数据从第2行开始        If BestDict.Exists(BatchArr(DataRow - 1, 1)) Then            wsSource.Cells(DataRow, 1).Interior.Color = RGB(173, 216, 230) ' 浅蓝色            wsSource.Cells(DataRow, 2).Interior.Color = RGB(173, 216, 230) ' 浅蓝色        End If    Next DataRow    ' 单元格（如E2）显示汇总信息    wsSource.Range("E2").Value = "目标: " & TargetQty & "， 实际凑单: " & BestSum    Set BestDict = Nothing    MsgBox "凑单完成！实际发货量为：" & BestSum & "件。最佳组合已在原表中用蓝色底色标识。", vbInformationEnd Sub