Excel·VBA定量装箱、凑数值金额、组合求和问题

如图：对图中A-C列数据，根据C列数量按照一定的取值范围，组成一个分组装箱，要求如下：
1，每箱数量最好凑足50，否则为47-56之间；
2，图中每行数据不得拆分；
3，按顺序对分组装箱结果进行编号，如D列中BS0001；
4，生成分组装箱结果（包含B-C列数据），以及单独生成最终无法装箱的数据

本问题本质上是组合求和问题，调用了combin_arr1函数，代码详见《Excel·VBA数组组合函数、组合求和》（如需使用代码需复制）

实现方法1

代码思路：持续不断组合
1，对数据读取为字典，行号为键数量为值；
2，对行号数组从2-N依次进行组合，判断是否符合取值范围；
3，对符合取值范围的行号组合，在res数组对应行号中写入装箱编号，并在字典中删除该行号
4，删除行号后，跳出后续循环遍历，并重复步骤2-3，直至无法删除行号，即没有符合范围的行号组合
5，在D列写入对应的装箱编号
注意：由于步骤4需要跳出循环，所以无法使用for…each遍历组合数组，否则报错该数组被固定或暂时锁定

Sub 装箱问题1()
    Dim arr, dict As Object, i&, j&, temp_sum, res, w&, dc&, brr, r&, c&
    target = 50: trr = Array(47, 56)  '目标值，范围
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    With Worksheets("数据")  '读取数据
        arr = .[a1].CurrentRegion: ReDim res(1 To UBound(arr)): res(1) = "箱号"
        For i = 2 To UBound(arr)
            If arr(i, 3) = target Then
                w = w + 1: res(i) = "BS" & Format(w, "000")
            Else
                dict(i) = arr(i, 3)
            End If
        Next
        dc = dict.Count
        Do    '2层do方便有符合目标值时跳出，并继续组合
            Do
                For j = 2 To dc
                    brr = combin_arr1(dict.keys, j)
                    For r = 1 To UBound(brr)
                        temp_sum = 0
                        For c = 1 To UBound(brr(r))
                            temp_sum = temp_sum + dict(brr(r)(c))
                        Next
                        If temp_sum >= trr(0) And temp_sum <= trr(1) Then
                            w = w + 1
                            For c = 1 To UBound(brr(r))
                                res(brr(r)(c)) = "BS" & Format(w, "000"): dict.Remove brr(r)(c)  '写入箱号，删除行号
                            Next
                            Exit Do
                        End If
                    Next
                Next
                If dc = dict.Count Then Exit Do  '无组合符合目标值，跳出
            Loop Until dc = 0
            If dc = dict.Count Then Exit Do
            dc = dict.Count
        Loop Until dc = 0
        .[d1].Resize(UBound(res), 1) = WorksheetFunction.Transpose(res)
    End With
    Debug.Print "组合完成，累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

实现方法2

代码思路：遍历组合，跳过重复行号
与实现方法2类似，但步骤4不同，在字典删除行号后，继续遍历组合，并判断每个组合中是否存在被删除的行号，如果存在则跳过本组合，直至无法删除行号，或剩余行号无法支持下一轮递增元素个数进行组合

Sub 装箱问题2()
    Dim arr, dict As Object, i&, j&, temp_sum, res, w&, dc&, brr, r&, c&
    target = 50: trr = Array(47, 56)  '目标值，范围
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    With Worksheets("数据")  '读取数据
        arr = .[a1].CurrentRegion: ReDim res(1 To UBound(arr)): res(1) = "箱号"
        For i = 2 To UBound(arr)
            If arr(i, 3) = target Then
                w = w + 1: res(i) = "BS" & Format(w, "000")
            Else
                dict(i) = arr(i, 3)
            End If
        Next
        For j = 2 To dict.Count
            If j > dict.Count Then Exit For  '所剩元素不足，结束
            brr = combin_arr1(dict.keys, j)
            For Each b In brr
                temp_sum = 0
                For Each bb In b
                    If Not dict.Exists(bb) Then
                        temp_sum = 0: Exit For  '重复跳过
                    Else
                        temp_sum = temp_sum + dict(bb)
                    End If
                Next
                If temp_sum >= trr(0) And temp_sum <= trr(1) Then
                    w = w + 1
                    For Each bb In b
                        res(bb) = "BS" & Format(w, "000"): dict.Remove bb  '写入箱号，删除行号
                    Next
                End If
            Next
        Next
        .[d1].Resize(UBound(res), 1) = WorksheetFunction.Transpose(res)
    End With
    Debug.Print "组合完成，累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

实现方法3

实现方法1和实现方法2，都没有满足要求中“每箱数量最好凑足50”，仅对每行数量优先判断是否等于50，对于后续组合中都是符合范围即可
因此，对实现方法2添加1个for循环，第1遍组合满足target，第2遍组合满足目标值trr范围

Sub 装箱问题3()
    Dim arr, dict As Object, i&, j&, temp_sum, res, w&, dc&, brr, r&, c&
    target = 50: trr = Array(47, 56)  '目标值，范围
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    With Worksheets("数据")  '读取数据
        arr = .[a1].CurrentRegion: ReDim res(1 To UBound(arr)): res(1) = "箱号"
        For i = 2 To UBound(arr)
            If arr(i, 3) = target Then
                w = w + 1: res(i) = "BS" & Format(w, "000")
            Else
                dict(i) = arr(i, 3)
            End If
        Next
        For n = 1 To 2  '第1遍组合满足target，第2遍组合满足目标值trr范围
            For j = 2 To dict.Count
                If j > dict.Count Then Exit For  '所剩元素不足，结束
                brr = combin_arr1(dict.keys, j)
                For Each b In brr
                    temp_sum = 0
                    For Each bb In b
                        If Not dict.Exists(bb) Then
                            temp_sum = 0: Exit For  '重复跳过
                        Else
                            temp_sum = temp_sum + dict(bb)
                        End If
                    Next
                    If n = 1 And temp_sum = target Then
                        w = w + 1
                        For Each bb In b
                            res(bb) = "BS" & Format(w, "000"): dict.Remove bb  '写入箱号，删除行号
                        Next
                    ElseIf n = 2 And temp_sum >= trr(0) And temp_sum <= trr(1) Then
                        w = w + 1
                        For Each bb In b
                            res(bb) = "BS" & Format(w, "000"): dict.Remove bb  '写入箱号，删除行号
                        Next
                    End If
                Next
            Next
        Next
        .[d1].Resize(UBound(res), 1) = WorksheetFunction.Transpose(res)
    End With
    Debug.Print "组合完成，累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

3种实现方法生成结果、对比、耗时

图中C列中的数量为1-50范围内的随机数，D列即为结果
分别对3种方法生成结果进行统计、对比：
方法1、2生成结果完全相同，数量分布不集中；方法3最终装箱的箱数也更少，且数量集中在50，但剩余行数多
400行数据测试，方法1、2剩余4行，方法3剩余15行

3种方法代码运行速度，分别测试300行、400行数据的耗时秒数
方法3对比方法2需要多生成、遍历一遍组合，由于组合数成指数递增，因此其400行相比300行耗时大幅增加，且电脑内存最高占用6G。如果要使用方法3且数据量较大，最好还是分段运行代码，避免耗时过久

装箱结果整理

编号无序

字典以箱号为键，值为数组

Sub 装箱结果输出1无序()
    Dim arr, dict As Object, i&, j&, r&, c&, max_c&, rng As Range, xh, dw, sl
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    With Worksheets("数据")  '读取数据
        arr = .[a1].CurrentRegion: ReDim res(1 To UBound(arr) * 2, 1 To 10)
        res(1, 1) = "箱号": r = 0: Set rng = .Cells(1, 1).Resize(1, 3)  '表头
        For i = 2 To UBound(arr)
            If Len(arr(i, 4)) Then
                xh = arr(i, 4): dw = arr(i, 2): sl = arr(i, 3)
                If Not dict.Exists(xh) Then
                    r = r + 2: dict(xh) = Array(r, 2, sl)  '箱号对应的行列号，数量合计
                    res(dict(xh)(0), 1) = xh    '箱号、单位号、数量赋值
                    res(dict(xh)(0), dict(xh)(1)) = dw
                    res(dict(xh)(0) + 1, dict(xh)(1)) = sl
                Else
                    c = dict(xh)(1) + 1: hj = dict(xh)(2) + sl  '数量合计
                    dict(xh) = Array(dict(xh)(0), c, hj)
                    res(dict(xh)(0), dict(xh)(1)) = dw  '单位号、数量赋值
                    res(dict(xh)(0) + 1, dict(xh)(1)) = sl
                    max_c = WorksheetFunction.Max(max_c, c)  '最大列数
                End If
            Else
                Set rng = Union(rng, .Cells(i, 1).Resize(1, 3))
            End If
        Next
    End With
    With Worksheets("结果")  '写入结果
        r = r + 1: max_c = max_c + 1: res(1, max_c) = "总件数"
        For i = 2 To r
            If Len(res(i, 1)) = 0 Then
                res(i, 1) = "数量": res(i, max_c) = dict(res(i - 1, 1))(2)
            End If
        Next
        For j = 2 To max_c - 1
            res(1, j) = "单位号" & (j - 1)
        Next
        .[a1].Resize(r, max_c) = res
        If Not rng Is Nothing Then rng.Copy .Cells(1, max_c + 2)  '无法装箱
    End With
    Debug.Print "累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

生成结果：对方法2生成数据（即本文图1）进行整理

编号有序

字典嵌套字典，代码速度较无序版稍慢
为保证编号有序，以下代码使用了一维数组排序，调用了bubble_sort函数，代码详见《Excel·VBA数组冒泡排序函数》（如需使用代码需复制）

Sub 装箱结果输出2有序()
    Dim arr, dict As Object, i&, j&, r&, c&, max_c&, rng As Range, xh, dw, sl
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    With Worksheets("数据")  '读取数据
        arr = .[a1].CurrentRegion: ReDim res(1 To UBound(arr) * 2, 1 To 10)
        res(1, 1) = "箱号": r = 0: Set rng = .Cells(1, 1).Resize(1, 3)  '表头
        For i = 2 To UBound(arr)
            If Len(arr(i, 4)) Then
                xh = arr(i, 4): dw = arr(i, 2): sl = arr(i, 3)
                If Not dict.Exists(xh) Then
                    Set dict(xh) = CreateObject("scripting.dictionary")
                End If
                dict(xh)(dw) = dict(xh)(dw) + sl
            Else
                Set rng = Union(rng, .Cells(i, 1).Resize(1, 3))
            End If
        Next
        krr = bubble_sort(dict.keys)  '有序箱号
        For Each k In krr
            r = r + 2: c = 1: res(r, c) = k
            For Each kk In dict(k).keys
                c = c + 1: res(r, c) = kk: res(r + 1, c) = dict(k)(kk)
            Next
            max_c = WorksheetFunction.Max(max_c, c)  '最大列数
        Next
    End With
    With Worksheets("结果")  '写入结果
        r = r + 1: max_c = max_c + 1: res(1, max_c) = "总件数"
        For i = 2 To r
            If Len(res(i, 1)) = 0 Then
                res(i, 1) = "数量"
                res(i, max_c) = WorksheetFunction.sum(dict(res(i - 1, 1)).items)
            End If
        Next
        For j = 2 To max_c - 1
            res(1, j) = "单位号" & (j - 1)
        Next
        .[a1].Resize(r, max_c) = res
        If Not rng Is Nothing Then rng.Copy .Cells(1, max_c + 2)  '无法装箱
    End With
    Debug.Print "累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

生成结果：对方法2生成数据（即本文图1）进行整理

附件：《Excel·VBA定量装箱、凑数值金额、组合求和问题（附件）》

扩展阅读：《excelhome-一个装箱难题》