如圖：對圖中A-C列數(shù)據(jù)，根據(jù)C列數(shù)量按照一定的取值范圍，組成一個分組裝箱，要求如下：
1，每箱數(shù)量最好湊足50，否則為47-56之間；
2，圖中每行數(shù)據(jù)不得拆分；
3，按順序?qū)Ψ纸M裝箱結(jié)果進(jìn)行編號，如D列中BS0001；
4，生成分組裝箱結(jié)果（包含B-C列數(shù)據(jù)），以及單獨(dú)生成最終無法裝箱的數(shù)據(jù)

本問題本質(zhì)上是組合求和問題，調(diào)用了combin_arr1函數(shù)，代碼詳見《Excel·VBA數(shù)組組合函數(shù)、組合求和》（如需使用代碼需復(fù)制）

實(shí)現(xiàn)方法1

代碼思路：持續(xù)不斷組合
1，對數(shù)據(jù)讀取為字典，行號為鍵數(shù)量為值；
2，對行號數(shù)組從2-N依次進(jìn)行組合，判斷是否符合取值范圍；
3，對符合取值范圍的行號組合，在res數(shù)組對應(yīng)行號中寫入裝箱編號，并在字典中刪除該行號
4，刪除行號后，跳出后續(xù)循環(huán)遍歷，并重復(fù)步驟2-3，直至無法刪除行號，即沒有符合范圍的行號組合
5，在D列寫入對應(yīng)的裝箱編號
注意：由于步驟4需要跳出循環(huán)，所以無法使用for…each遍歷組合數(shù)組，否則報(bào)錯該數(shù)組被固定或暫時鎖定

Sub 裝箱問題1()Dim arr, dict As Object, i&, j&, temp_sum, res, w&, dc&, brr, r&, c&target = 50: trr = Array(47, 56)  '目標(biāo)值，范圍Set dict = CreateObject("scripting.dictionary"): tm = TimerWith Worksheets("數(shù)據(jù)")  '讀取數(shù)據(jù)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方便有符合目標(biāo)值時跳出，并繼續(xù)組合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  '無組合符合目標(biāo)值，跳出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 "組合完成，累計(jì)用時" & Format(Timer - tm, "0.00")  '耗時
End Sub

實(shí)現(xiàn)方法2

代碼思路：遍歷組合，跳過重復(fù)行號
與實(shí)現(xiàn)方法2類似，但步驟4不同，在字典刪除行號后，繼續(xù)遍歷組合，并判斷每個組合中是否存在被刪除的行號，如果存在則跳過本組合，直至無法刪除行號，或剩余行號無法支持下一輪遞增元素個數(shù)進(jìn)行組合

Sub 裝箱問題2()Dim arr, dict As Object, i&, j&, temp_sum, res, w&, dc&, brr, r&, c&target = 50: trr = Array(47, 56)  '目標(biāo)值，范圍Set dict = CreateObject("scripting.dictionary"): tm = TimerWith Worksheets("數(shù)據(jù)")  '讀取數(shù)據(jù)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  '所剩元素不足，結(jié)束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  '重復(fù)跳過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 "組合完成，累計(jì)用時" & Format(Timer - tm, "0.00")  '耗時
End Sub

實(shí)現(xiàn)方法3

實(shí)現(xiàn)方法1和實(shí)現(xiàn)方法2，都沒有滿足要求中“每箱數(shù)量最好湊足50”，僅對每行數(shù)量優(yōu)先判斷是否等于50，對于后續(xù)組合中都是符合范圍即可
因此，對實(shí)現(xiàn)方法2添加1個for循環(huán)，第1遍組合滿足target，第2遍組合滿足目標(biāo)值trr范圍

Sub 裝箱問題3()Dim arr, dict As Object, i&, j&, temp_sum, res, w&, dc&, brr, r&, c&target = 50: trr = Array(47, 56)  '目標(biāo)值，范圍Set dict = CreateObject("scripting.dictionary"): tm = TimerWith Worksheets("數(shù)據(jù)")  '讀取數(shù)據(jù)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遍組合滿足目標(biāo)值trr范圍For j = 2 To dict.CountIf j > dict.Count Then Exit For  '所剩元素不足，結(jié)束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  '重復(fù)跳過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 "組合完成，累計(jì)用時" & Format(Timer - tm, "0.00")  '耗時
End Sub

3種實(shí)現(xiàn)方法生成結(jié)果、對比、耗時

圖中C列中的數(shù)量為1-50范圍內(nèi)的隨機(jī)數(shù)，D列即為結(jié)果
分別對3種方法生成結(jié)果進(jìn)行統(tǒng)計(jì)、對比：
方法1、2生成結(jié)果完全相同，數(shù)量分布不集中；方法3最終裝箱的箱數(shù)也更少，且數(shù)量集中在50，但剩余行數(shù)多
400行數(shù)據(jù)測試，方法1、2剩余4行，方法3剩余15行

3種方法代碼運(yùn)行速度，分別測試300行、400行數(shù)據(jù)的耗時秒數(shù)
方法3對比方法2需要多生成、遍歷一遍組合，由于組合數(shù)成指數(shù)遞增，因此其400行相比300行耗時大幅增加，且電腦內(nèi)存最高占用6G。如果要使用方法3且數(shù)據(jù)量較大，最好還是分段運(yùn)行代碼，避免耗時過久

裝箱結(jié)果整理

編號無序

字典以箱號為鍵，值為數(shù)組

Sub 裝箱結(jié)果輸出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("數(shù)據(jù)")  '讀取數(shù)據(jù)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)  '箱號對應(yīng)的行列號，數(shù)量合計(jì)res(dict(xh)(0), 1) = xh    '箱號、單位號、數(shù)量賦值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  '數(shù)量合計(jì)dict(xh) = Array(dict(xh)(0), c, hj)res(dict(xh)(0), dict(xh)(1)) = dw  '單位號、數(shù)量賦值res(dict(xh)(0) + 1, dict(xh)(1)) = slmax_c = WorksheetFunction.Max(max_c, c)  '最大列數(shù)End IfElseSet rng = Union(rng, .Cells(i, 1).Resize(1, 3))End IfNextEnd WithWith Worksheets("結(jié)果")  '寫入結(jié)果r = r + 1: max_c = max_c + 1: res(1, max_c) = "總件數(shù)"For i = 2 To rIf Len(res(i, 1)) = 0 Thenres(i, 1) = "數(shù)量": 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 "累計(jì)用時" & Format(Timer - tm, "0.00")  '耗時
End Sub

生成結(jié)果：對方法2生成數(shù)據(jù)（即本文圖1）進(jìn)行整理

編號有序

字典嵌套字典，代碼速度較無序版稍慢
為保證編號有序，以下代碼使用了一維數(shù)組排序，調(diào)用了bubble_sort函數(shù)，代碼詳見《Excel·VBA數(shù)組冒泡排序函數(shù)》（如需使用代碼需復(fù)制）

Sub 裝箱結(jié)果輸出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("數(shù)據(jù)")  '讀取數(shù)據(jù)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)  '最大列數(shù)NextEnd WithWith Worksheets("結(jié)果")  '寫入結(jié)果r = r + 1: max_c = max_c + 1: res(1, max_c) = "總件數(shù)"For i = 2 To rIf Len(res(i, 1)) = 0 Thenres(i, 1) = "數(shù)量"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 "累計(jì)用時" & Format(Timer - tm, "0.00")  '耗時
End Sub

生成結(jié)果：對方法2生成數(shù)據(jù)（即本文圖1）進(jìn)行整理

附件：《Excel·VBA定量裝箱、湊數(shù)值金額、組合求和問題（附件）》

擴(kuò)展閱讀：《excelhome-一個裝箱難題》