求1-n个数总和符合目标值的 高效【组合递归方法】

山菊花

递归用得好。
用字典去重复会更快一些。

1. Public sj, d, jg(), m, n, k, jg2(), h, cnt
   
2. Sub kagawa()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     tms = Timer
   
5.     m = [a1].End(4).Row - 1: n = [b5]: h = [b2] '获取元素个数m，组合个数n，目标总和h
   
6.     sj0 = [a2].Resize(m): [a2].Resize(m).Sort [a2], 1, , , 2 '原始数据，按从小到大排序
   
7.     sj = [a2].Resize(m) '排序后数据读入原始数据数组sj
   
8.     [a2].Resize(m) = sj0 '恢复原始数据的排序状态
   
9.     If n > m Then AC = 65536 Else AC = WorksheetFunction.Combin(m, n)
   
10.     If AC > 65535 Then ReDim jg(65535, n) Else ReDim jg(AC, n) '计算并定义结果数组jg
    
11.     k = 1: cnt = 0 '结果序数k归零，全部计算次数cnt归零
    
12.     ReDim jg2(65536, 0) '定义输出所有计算过程明细的结果数组jg2
    
13.     Call bcfhdg("", 0, 0, 0) '调用递归过程代码
    
14.     '以下为输出结果部分的代码，解释从略
    
15.     jg(0, 0) = "Summary":    For i = 1 To n: jg(0, i) = "n" & i: Next
    
16.     [e1].CurrentRegion = "": If k > 1 Then [e1].Resize(k, n + 1) = jg
    
17.     'If cnt > 1 Then If cnt > 65535 Then [d1].Resize(65536) = jg2 Else [d1].Resize(cnt) = jg2
    
18.     [d1] = "<= " & h & " Detail: " & cnt - 1
    
19.     [e1].Resize(, n + 2).EntireColumn.AutoFit
    
20.     MsgBox "Calc " & cnt - 1 & " ,Get " & k - 1 & " result." & vbCr & Format(Timer - tms, "0.000s")
    
21. End Sub
    
22. Sub bcfhdg(s, r, i, t%) '递归过程代码
    
23. '    If cnt < 65536 Then jg2(cnt, 0) = s '"=" & Mid(s, 2) '如果不想看详细组合过程，把这句注释掉速度加快
    
24. '    cnt = cnt + 1
    
25.     If r = h Then '如果计算总和结果r  符合目标总和值h
    
26.         If n > m Or t = n Then '当n>m时输出结果，或当n为小于等于m的指定值且当前个数t=n时
    
27.             If Not d.exists(s) Then
    
28.                 d.Add s, Nothing
    
29.                 p = Split(s, "+")
    
30.                 For j = 1 To UBound(p)
    
31.                     jg(k, j) = p(j) '组合结果写入数组jg
    
32.                 Next
    
33.                 jg(k, 0) = "=" & Mid(s, 2) '第1列写入完整计算式
    
34.                 k = k + 1 '结果序号递增+1
    
35.             End If
    
36.         End If
    
37.         Exit Sub '结束递归(因为以后再加一个数的话肯定会超过目标值h)
    
38.     End If
    
39.     If t = n Then Exit Sub    '如果n>m即不指定组合个数时继续，否则停止
    
40.     For j = i + 1 To m
    
41.         If r + sj(j, 1) > h Then Exit For '如果下一个加总结果r>目标值h，则可推出循环。
    
42.         Call bcfhdg(s & "+" & sj(j, 1), r + sj(j, 1), j, t + 1) '继续调用递归代码，保证递归继续
    
43.     Next j
    
44. End Sub

复制代码

qigengzier

占座研究了，好贴必须顶

findingyuzi

什么时候才能理解和吃透这些代码....

山菊花

推荐两个帖子：
《归去来兮－－漫谈递归》----qee用

《递归（基础教程）》----彭希仁

《[分享] 生成 m选n 的所有组合，可指定组合的和值，每秒生成400万个组合，带详细注释的代码》---- 灰袍法师

deer_deer

绝对的精华贴呀, 啥时偶才可以写出这样的VBA呢

amiaosheng

代码、注释都很全面。
正是我们学习VBA的好机会
谢谢！

zhangzhang

好帖，值得学习、收藏。

Zamyi

速度还需要提高。

灰袍法师

Zamyi 发表于 2012-8-22 17:00
速度还需要提高。

其实，有了 生成组合 的程序，在此基础上加个 求指定和值的组合，是锦上添花。
如果目的是 求解子集和问题
那么根本就不应该用 穷举组合的方法了，所以就不必再速度上在苛求了，反正这个算法也不是最高效的。

据我所知，比较有效的求解子集和方法就是
1 Lingo软件内置的 LLL 算法，这方法说白了就是 剔除不大可能出现的数值，降低求解规模
2 两表法，以及由此发展出的 四表法，这个方法也是穷举，不过采用了分治思想，所以只需穷举一半的数字，比简单穷举快 2^(n/2) 倍，相当不错了。
3 我发过的 不断求和法，这个方法不能求解很大的数值，但对于小数值是非常高效的
4 最常用的动态规划（剪枝法），这个方法最简明，但碰到不利情况也是无法求解。
目前论坛上有 1，3，4 这三种方法的解决贴，合用的话，可以解决论坛出现过的一切提问贴。
我也就懒得再研究了。

cwjiayou

我无语了。我决心一定学好。