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 = TimerWith Worksheets("数据")  '读取数据arr = .[a1].CurrentRegion: ReDim res(1 To UBound(arr)): res(1) = "箱号"For i = 2 To UBound(arr)If arr(i, 3) = target Thenw = w + 1: res(i) = "BS" & Format(w, "000")Elsedict(i) = arr(i, 3)End IfNextdc = dict.CountDo    '2层do方便有符合目标值时跳出，并继续组合DoFor j = 2 To dcbrr = combin_arr1(dict.keys, j)For r = 1 To UBound(brr)temp_sum = 0For c = 1 To UBound(brr(r))temp_sum = temp_sum + dict(brr(r)(c))NextIf temp_sum >= trr(0) And temp_sum <= trr(1) Thenw = w + 1For c = 1 To UBound(brr(r))res(brr(r)(c)) = "BS" & Format(w, "000"): dict.Remove brr(r)(c)  '写入箱号，删除行号NextExit DoEnd IfNextNextIf dc = dict.Count Then Exit Do  '无组合符合目标值，跳出Loop Until dc = 0If dc = dict.Count Then Exit Dodc = dict.CountLoop Until dc = 0.[d1].Resize(UBound(res), 1) = WorksheetFunction.Transpose(res)End WithDebug.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 = TimerWith Worksheets("数据")  '读取数据arr = .[a1].CurrentRegion: ReDim res(1 To UBound(arr)): res(1) = "箱号"For i = 2 To UBound(arr)If arr(i, 3) = target Thenw = w + 1: res(i) = "BS" & Format(w, "000")Elsedict(i) = arr(i, 3)End IfNextFor j = 2 To dict.CountIf j > dict.Count Then Exit For  '所剩元素不足，结束brr = combin_arr1(dict.keys, j)For Each b In brrtemp_sum = 0For Each bb In bIf Not dict.Exists(bb) Thentemp_sum = 0: Exit For  '重复跳过Elsetemp_sum = temp_sum + dict(bb)End IfNextIf temp_sum >= trr(0) And temp_sum <= trr(1) Thenw = w + 1For Each bb In bres(bb) = "BS" & Format(w, "000"): dict.Remove bb  '写入箱号，删除行号NextEnd IfNextNext.[d1].Resize(UBound(res), 1) = WorksheetFunction.Transpose(res)End WithDebug.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 = TimerWith Worksheets("数据")  '读取数据arr = .[a1].CurrentRegion: ReDim res(1 To UBound(arr)): res(1) = "箱号"For i = 2 To UBound(arr)If arr(i, 3) = target Thenw = w + 1: res(i) = "BS" & Format(w, "000")Elsedict(i) = arr(i, 3)End IfNextFor n = 1 To 2  '第1遍组合满足target，第2遍组合满足目标值trr范围For j = 2 To dict.CountIf j > dict.Count Then Exit For  '所剩元素不足，结束brr = combin_arr1(dict.keys, j)For Each b In brrtemp_sum = 0For Each bb In bIf Not dict.Exists(bb) Thentemp_sum = 0: Exit For  '重复跳过Elsetemp_sum = temp_sum + dict(bb)End IfNextIf n = 1 And temp_sum = target Thenw = w + 1For Each bb In bres(bb) = "BS" & Format(w, "000"): dict.Remove bb  '写入箱号，删除行号NextElseIf n = 2 And temp_sum >= trr(0) And temp_sum <= trr(1) Thenw = w + 1For Each bb In bres(bb) = "BS" & Format(w, "000"): dict.Remove bb  '写入箱号，删除行号NextEnd IfNextNextNext.[d1].Resize(UBound(res), 1) = WorksheetFunction.Transpose(res)End WithDebug.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, slSet dict = CreateObject("scripting.dictionary"): tm = TimerWith 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)) Thenxh = arr(i, 4): dw = arr(i, 2): sl = arr(i, 3)If Not dict.Exists(xh) Thenr = r + 2: dict(xh) = Array(r, 2, sl)  '箱号对应的行列号，数量合计res(dict(xh)(0), 1) = xh    '箱号、单位号、数量赋值res(dict(xh)(0), dict(xh)(1)) = dwres(dict(xh)(0) + 1, dict(xh)(1)) = slElsec = 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)) = slmax_c = WorksheetFunction.Max(max_c, c)  '最大列数End IfElseSet rng = Union(rng, .Cells(i, 1).Resize(1, 3))End IfNextEnd WithWith Worksheets("结果")  '写入结果r = r + 1: max_c = max_c + 1: res(1, max_c) = "总件数"For i = 2 To rIf Len(res(i, 1)) = 0 Thenres(i, 1) = "数量": res(i, max_c) = dict(res(i - 1, 1))(2)End IfNextFor j = 2 To max_c - 1res(1, j) = "单位号" & (j - 1)Next.[a1].Resize(r, max_c) = resIf Not rng Is Nothing Then rng.Copy .Cells(1, max_c + 2)  '无法装箱End WithDebug.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, slSet dict = CreateObject("scripting.dictionary"): tm = TimerWith 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)) Thenxh = arr(i, 4): dw = arr(i, 2): sl = arr(i, 3)If Not dict.Exists(xh) ThenSet dict(xh) = CreateObject("scripting.dictionary")End Ifdict(xh)(dw) = dict(xh)(dw) + slElseSet rng = Union(rng, .Cells(i, 1).Resize(1, 3))End IfNextkrr = bubble_sort(dict.keys)  '有序箱号For Each k In krrr = r + 2: c = 1: res(r, c) = kFor Each kk In dict(k).keysc = c + 1: res(r, c) = kk: res(r + 1, c) = dict(k)(kk)Nextmax_c = WorksheetFunction.Max(max_c, c)  '最大列数NextEnd WithWith Worksheets("结果")  '写入结果r = r + 1: max_c = max_c + 1: res(1, max_c) = "总件数"For i = 2 To rIf Len(res(i, 1)) = 0 Thenres(i, 1) = "数量"res(i, max_c) = WorksheetFunction.sum(dict(res(i - 1, 1)).items)End IfNextFor j = 2 To max_c - 1res(1, j) = "单位号" & (j - 1)Next.[a1].Resize(r, max_c) = resIf Not rng Is Nothing Then rng.Copy .Cells(1, max_c + 2)  '无法装箱End WithDebug.Print "累计用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

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

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

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