利用背包算法解决分组凑数问题

香川群子

分组凑数问题，最近几年问的人也比较多。

问题描述如下：

【分组凑数问题】
从已知数据中，寻找<=目标值的组合，勾选列出后继续，直至找不到符合条件的组合为止。

【限制条件】：
每一组合中的数据不可重复使用。
尽量提取最接近目标值的组合。

……
通常，我使用随机算法、或使用香川凑数算法的Do循环解决问题。速度效率令人满意。
但是代码算法不容易被人理解，所以我也一直没有分享给大家。

……
最近在研究背包算法时，想到这个也可以用作凑数，进一步用于分组凑数，
今天就把背包算法代码进行了分组凑数的适用化处理，写成了可以随意使用的程序，分享给大家。

香川群子

似乎也可以用来解决一维下料问题……

但是目前是手工确定选用合适规格，应该要能自动化才算实用。

香川群子

代码以及注释：

1. Sub test() 'by kagawa 2017/7/24 背包算法解决分组凑数问题
   
2.     Dim ar, br, cr(), h&, k&, l&, m&, n&, r&, tms#
   
3.     tms = Timer
   
4.    
   
5.     m = [b2].End(4).Row - 1 '数据个数m
   
6.     ar = [b2].Resize(m, 3) '读取B:D 3列 分组原始数据、权重、备注信息
   
7.     br = [g2].Resize(m) '读取G列 分组目标限额数据
   
8.     ReDim cr(1 To m) '定义记录分组序号的数组cr
   
9.    
   
10.     [g1].CurrentRegion.Offset(1, 1) = ""
    
11.     r = m
    
12.     If WorksheetFunction.Count([c2].Resize(m)) = m Then l = 2 Else l = 1 '检查C列是否为权重数据
    
13.     For k = 1 To m '依次进行分组计算
    
14.         
    
15.         h = br(k, 1): If h = 0 Then h = br(k - 1, 1): br(k, 1) = h: Cells(k + 1, 7) = h
    
16.         '读取分组目标限额、如本行为空则继承上一行数值h
    
17.         
    
18.         n = GetDP(ar, cr, h, k, l) '调用背包算法 进行<=h的凑数 并返回有效组的元素个数
    
19.         
    
20.         If n = 0 Then Exit For '如找不到解则退出
    
21.         
    
22.         r = r - n '计算数据剩余个数r
    
23.         If r = 0 Then Exit For '如r=0即全部数据都已经分组完毕也退出
    
24.         
    
25. '        [e2].Resize(m) = WorksheetFunction.Transpose(cr)'调试时输出每一步的分组结果
    
26.     Next
    
27.    
    
28.     [e2].Resize(m) = WorksheetFunction.Transpose(cr) '输出最终分组记录结果
    
29.     [a2].Resize(m, 5).Sort [e2], 1, [b2], , 1, [a2], 1, 2 '分组结果排序
    
30.     MsgBox Format(Timer - tms, "0.000s") & vbCr & "已经完成 " & k & " 个分组"
    
31. End Sub
    
32. Function GetDP(ar, cr, h&, k&, l&) '老窖提供生成DP_Knapsack表的算法、香川2017/07/23 修改
    
33.     Dim sj&(), DP&(), i&, j&, m&, n&, v&, v1&, r&, s1$, s2$
    
34.    
    
35.     m = 0: ReDim sj&(1 To UBound(ar), 2)
    
36.     For i = 1 To UBound(ar)
    
37.         If cr(i) = 0 Then m = m + 1: sj(m, 0) = i: sj(m, 1) = ar(i, 1): sj(m, 2) = ar(i, l)
    
38.     Next
    
39.     '以上对照扣除已分组数据，把剩余有效数据重新整理、写入sj数组
    
40.    
    
41.     ReDim DP&(m, h) '定义DP表数组
    
42.     For i = 1 To m '填写DP表
    
43.         For j = 1 To h
    
44.             If sj(i, 1) > j Then
    
45.                 DP(i, j) = DP(i - 1, j) '加入后超过当前值则不可加入，直接继承上一行结果
    
46.             Else
    
47.                 v1 = DP(i - 1, j - sj(i, 1)) + sj(i, l) '计算加入背包后的结果v1
    
48.                 v = DP(i - 1, j) '不加入背包时的结果v
    
49.                 If v1 > v Then DP(i, j) = v1 Else DP(i, j) = v '取上述两种结果中的最大值
    
50.             End If
    
51.         Next
    
52.     Next
    
53.    
    
54.     '按上述动态规划的背包算法遍历所有可能的组合得到最大值的DP数据表，据此可以得到所有解
    
55.     i = m: j = h '下面代码只选取第1种低位有效组合
    
56.     Do
    
57.         Do
    
58.             If DP(i, j) = DP(i, j - 1) Then j = j - 1 Else Exit Do '背包值相同时左移1列
    
59.         Loop Until j = 0
    
60.         Do
    
61.             If DP(i, j) = DP(i - 1, j) Then i = i - 1 Else Exit Do '背包值相同时上移1行
    
62.         Loop Until i = 1
    
63.         If DP(i, j) = 0 Then Exit Do '无解时退出
    
64.         
    
65.         '背包值不同时即可提取本组的对应元素
    
66.         n = n + 1 '记录本组使用元素个数
    
67.         cr(sj(i, 0)) = k '数组cr中记录分组序号k
    
68.         r = r + sj(i, 1) '统计本组凑数总和r
    
69.         s1 = s1 & "+" & sj(i, 1) '合并本组凑数结果字符串
    
70.         s2 = s2 & "+" & ar(sj(i, 0), 3) '合并本组信息字符串
    
71.         j = j - sj(i, 1): i = i - 1 '
    
72.     Loop Until DP(i, j) = 0 '提取完毕退出
    
73.    
    
74.     If n Then '本组有效时 输出结果到工作表
    
75.         Cells(k + 1, 8) = "=" & Mid(s1, 2) '本组凑数总和
    
76.         Cells(k + 1, 9) = h - r            '本组和目标值的差额
    
77.         Cells(k + 1, 10) = Mid(s2, 2)      '本组信息合并字符串
    
78.     End If
    
79.    
    
80.     GetDP = n '函数返回本组含元素个数n
    
81. End Function
    

复制代码

⊙⊙小噤○

占位学习。收藏备用。向高手致敬

blackttea1

收藏备用。向高手致敬

SCL5801

这个好----

chenxuemin0815

站位学习。

海婷

占位学习,向高手致敬!

lzqlaj

《数论》里的多元一次方程的求解问题。

165530605

致敬~！！！！！！！！！！！！！！！