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

香川群子

元素不重复组合求和.rar (15.3 KB, 下载次数: 1727)

2013-1-20 21:27 上传

点击文件名下载附件

附件再次更新。
输出结果列数按元素实际个数。

为提高计算速度和避免浮点运算差异，要求参与计算的原始数据统一转换为整数。

1. 
   
2. 
   
3. 
   
4. Dim sj, jg(), m%, n%, k&, h1%, h2%, cnt&
   
5. '定义递归所需调用的公共变量：
   
6. 'sj 为任意变量，用来获取原始数据到数组
   
7. 'jg()为储存结果的数组，大小在主代码中重新Redim定义
   
8. 'm为组合元素总数
   
9. 'n为抽取元素个数参数，范围1-m之间时取定值个数，即程序仅仅计算返回指定元素个数的组合。
   
10. '   当n取值为空或输入n>m(如n=m+1)时则程序计算返回所有符合要求的组合而不论元素个数。
    
11. 'k为结果序号，在代码运行过程中递增+1
    
12. 'h1是总和目标下限、h2是总和目标上限，即目标和值范围=[h1,h2]，如果h1=h2时，当然就只取完全相等的值。
    
13. 'cnt是所有递归计算次数。
    
14. Sub kagawa() '元素不重复组合求和 符合目标值范围[h1-h2] 的主过程代码
    
15.     tms = Timer
    
16.     m = [a1].End(4).Row - 1: sj0 = [a2].Resize(m): [a2].Resize(m).Sort [a2], 1, , , 2 '原始数据元素从小到大排序
    
17.     sj = [a2].Resize(m): [a2].Resize(m) = sj0 '排序后原始数据读入数组sj然后恢复工作表中原始数据状态
    
18.     h1 = [b2]: If [b3] = "" Then h2 = h1 Else h2 = [b3] '获取目标和值范围[h1-h2]
    
19.     If [b5] = "" Then n = m + 1 Else n = [b5] '组合元素个数指定,n为空时不指定个数给出所有解
    
20.     ReDim jg(65535, -1 To n) '定义结果数组大小 行数为Excel 2003最大行数 列数为指定元素个数
    
21.     k = 1: cnt = 0 'k和cnt参数归零
    
22.    
    
23.     Call bcfhdg(0, "", 0, 0)  '调用递归计算过程
    
24.     MsgBox "Calc " & cnt - 1 & " ,Get " & k - 1 & " result." & vbCr & Format(Timer - tms, "0.000s")
    
25.    
    
26.    
    
27.     '以下为输出结果代码，解释从略
    
28.     jg(0, -1) = "个数": n = jg(0, 0): jg(0, 0) = "总和": For i = 1 To n: jg(0, i) = "n" & i: Next
    
29.     [e1].CurrentRegion.Clear: [b6] = k - 1: [b7] = cnt - 1
    
30.     If k > 1 Then [e1].Resize(k, n + 2) = jg: [e1].Resize(, n + 2).EntireColumn.AutoFit '
    
31.    
    
32. End Sub
    
33. Sub bcfhdg(r%, s$, i%, t%) '不重复组合求和的递归过程代码
    
34. '参数s是组合结果的文本格式、r是组合结果的和值、i是递归进程位置指针、t是组合抽取个数指针
    
35.     Dim j%
    
36.     cnt = cnt + 1 '递归计算次数递增+1
    
37.    
    
38.     p = Split(s, "+")
    
39.     For j = 1 To UBound(p)
    
40.         jg(0, j) = p(j) '当前递归结果分解存入状态栈，以便下一次递归是检查比对
    
41.     Next
    
42.    
    
43.     If r >= h1 And r <= h2 Then '如果本次递归组合结果的和值已经在总和目标范围内，则：
    
44.         If n > m Or t = n Then '如果参数n>m是则结果都要，或者n在1-m之间时必须t=n即抽取个数正好符合条件。
    
45.             If t > jg(0, 0) Then jg(0, 0) = t
    
46.             jg(k, -1) = t
    
47.             For j = 1 To UBound(p)
    
48.                 jg(k, j) = p(j) '符合总和条件的本次递归结果写入结果数组。
    
49.             Next
    
50.             jg(k, 0) = "=" & Mid(s, 2) '第一列文本格式改写为=计算式，最后输出结果时直接得到计算式结果。
    
51.             k = k + 1 '结果序号递增+1
    
52.         End If
    
53.         'Exit Sub '退出以后的递归进程，加速计算过程。
    
54.         '注意：如果原始数据数值间隔小、目标和值的范围相对较大时，则这一句要注释掉，否则会漏掉一些正确的答案。
    
55.     End If
    
56.     If t = n Then Exit Sub 'n>m → go on 当n参数>m时应该继续，而n在1-m之间时因为t已经满足抽取个数则可退出递归进程。
    
57.    
    
58.     For j = i + 1 To m '递归遍历检查所有原始元素
    
59.         If r + sj(j, 1) > h2 Then Exit For '如果本次递归结果的和值已经大于总和目标范围上限，则可退出循环了。
    
60.         If CStr(sj(j, 1)) <> jg(0, t + 1) Then '检查本次递归进程中最新位置值，和前面上次递归状态栈比对，不重复才可继续
    
61.             If t < n - 1 Then jg(0, t + 2) = "" '递归最新状态栈位清空，否则会对下一次递归的比对造成错误干扰。
    
62.             Call bcfhdg(r + sj(j, 1), s & "+" & sj(j, 1), j, t + 1) '满足条件时，继续调用递归进行下一个组合位置的递归计算。
    
63.         End If
    
64.     Next j
    
65. End Sub
    
66. 
    

复制代码

补充内容 (2013-4-25 20:43):
65楼附件又做了很多改进。可以处理小数了。还可以把有效组合元素标注为黄色

香川群子

所谓组合求和，就是m个数中，任取1-n个组合并相加，要求总和等于固定的目标值。
求所有符合条件的组合解。


例如：1-10的10个自然数中，求总和=8的各种组合

结果如下：
+1+2+5
+1+3+4
+1+7
+2+6
+3+5
8

win2009

经典啊，高手，又学一招，学习啊
还是这样看方便

Public sj, jg(), m, n, k, jg2(), h1, h2, cnt
Sub kagawa()
    tms = Timer
    m = [a1].End(4).Row - 1: n = [b5]: h1 = [b2]: h2 = [b3]
    sj0 = [a2].Resize(m): [a2].Resize(m).Sort [a2], 1, , , 2
    sj = [a2].Resize(m)
    [a2].Resize(m) = sj0
    If n > m Then AC = 65536 Else AC = WorksheetFunction.Combin(m, n)
    If AC > 65535 Then ReDim jg(65535, n) Else ReDim jg(AC, n)
    k = 1: cnt = 0
    Call bcfhdg("", 0, 0, 0)  
    jg(0, 0) = "Summary":    For i = 1 To n: jg(0, i) = "n" & i: Next
    [e1].CurrentRegion = "": If k > 1 Then [e1].Resize(k, n + 1) = jg
    [d1] = "<= " & h & " Detail: " & cnt - 1
    [e1].Resize(, n + 2).EntireColumn.AutoFit
    MsgBox "Calc " & cnt - 1 & " ,Get " & k - 1 & " result." & vbCr & Format(Timer - tms, "0.000s")
End Sub
Sub bcfhdg(s, r, i, t%)
    cnt = cnt + 1
    p = Split(s, "+")
    For j = 1 To UBound(p)
        jg(0, j) = p(j)
    Next
    If r >= h1 And r <= h2 Then
        If n > m Or t = n Then
            For j = 1 To UBound(p)
                jg(k, j) = p(j)
            Next
            jg(k, 0) = "=" & Mid(s, 2)
            k = k + 1
        End If
    End If
    If t = n Then Exit Sub
    For j = i + 1 To m
        If r + sj(j, 1) > h2 Then Exit For 如果本次递归结果的和值已经大于总和目标范围上限，则可退出循环了。
        If CStr(sj(j, 1)) <> jg(0, t + 1) Then
            If t < n - 1 Then jg(0, t + 2) = ""
            Call bcfhdg(s & "+" & sj(j, 1), r + sj(j, 1), j, t + 1)
        End If
    Next j
End Sub

公有的 sj ,jg() ,m ,n ,k ,jg2() ,h1 ,h2 ,cnt
过程 kagawa()
    tms = 当前计时
    m = [a1] . 结束(4) . 行标 - 1: n = [b5]: h1 = [b2]: h2 = [b3]
    sj0 = [a2] . 重调大小(m): [a2] . 重调大小(m) . 排序 [a2] ,1 , , ,2
    sj = [a2] . 重调大小(m)
    [a2] . 重调大小(m) = sj0
    如果 n > m 那么 ac = 65536 否则 ac = 工作表公式 . combin(m ,n)
    如果 ac > 65535 那么 重定义变量 jg(65535 ,n) 否则 重定义变量 jg(ac ,n)
    k = 1: cnt = 0
    调用 bcfhdg("" ,0 ,0 ,0)  
    jg(0 ,0) = "summary":    循环范围 i = 1 到 n: jg(0 ,i) = "n" & i: 下一句
    [e1] . 当前区域 = "": 如果 k > 1 那么 [e1] . 重调大小(k ,n + 1) = jg
    [d1] = "<= " & h & " detail: " & cnt - 1
    [e1] . 重调大小( ,n + 2) . 全部列 . 自动调整
    消息框： "calc " & cnt - 1 & "   ，读取 " & k - 1 & " result . " & vbcr & 格式化输出(当前计时 - tms ,"0 . 000s")
结束 过程
过程 bcfhdg(s ,r ,i ,t%)
    cnt = cnt + 1
    p = 分割字符串(s ,"+")
    循环范围 j = 1 到 数组上限(p)
        jg(0 ,j) = p(j)
    下一句
    如果 r  >=  h1 并且 r <= h2 那么
        如果 n > m 或者 t = n 那么
            循环范围 j = 1 到 数组上限(p)
                jg(k ,j) = p(j)
            下一句
            jg(k ,0) = "=" & 截取字符串(s ,2)
            k = k + 1
        结束 如果
    结束 如果
    如果 t = n 那么 退出 过程
    循环范围 j = i + 1 到 m
        如果 r + sj(j ,1) > h2 那么 退出 循环范围 如果本次递归结果的和值已经大于总和目标范围上限  ，则可退出循环了。
        如果 转换为字符串(sj(j ,1))<>jg(0 ,t + 1) 那么
            如果 t < n - 1 那么 jg(0 ,t + 2) = ""
            调用 bcfhdg(s & "+" & sj(j ,1) ,r + sj(j ,1) ,j ,t + 1)
        结束 如果
    下一句 j
结束 过程

AVEL

好像之前法师有做过类似的。

香川群子

下面的递归代码，是固定取n个数的、不重复组合求定值和代码。

1. Public sj, jg(), jg2(), m, n, k, h, cnt
   
2. Sub kagawa() '不重复组合求和递归
   
3.     tms = Timer
   
4.     m = [a1].End(4).Row: n = [b1]:: h = [b2]
   
5.     sj0 = [a1].Resize(m): [a1].Resize(m).Sort [a1], 1, , , 2
   
6.     sj = [a1].Resize(m)
   
7.     [a1].Resize(m) = sj0
   
8.     AC = WorksheetFunction.Combin(m, n)
   
9.     If AC > 65536 Then ReDim jg(65535, n) Else ReDim jg(AC, n)
   
10.     k = 1: cnt = 0
    
11.    
    
12.     Call bcfhdg("", 0, 0)
    
13.    
    
14.     [d1].CurrentRegion = "": [d1].Resize(k, n + 1) = jg
    
15.     [d1] = "和": [e1].Resize(, n) = ""
    
16.     MsgBox cnt & vbCr & Timer - tms
    
17. End Sub
    
18. Sub bcfhdg(s, i, t%)
    
19.     cnt = cnt + 1
    
20.     If t = n Then
    
21.         p = Split(s, "+")
    
22.         jg(0, 0) = 0
    
23.         For j = 1 To n
    
24.             jg(0, j) = p(j)
    
25.             jg(0, 0) = jg(0, 0) + p(j)
    
26.             jg(k, j) = p(j)
    
27.         Next
    
28.         If jg(0, 0) = h Then jg(k, 0) = "=" & Mid(s, 2): k = k + 1
    
29.         Exit Sub
    
30.     End If
    
31.     For j = i + 1 To m
    
32.         If CStr(sj(j, 1)) <> jg(0, t + 1) Then
    
33.             If t < n - 1 Then jg(0, t + 2) = ""
    
34.             Call bcfhdg(s & "+" & sj(j, 1), j, t + 1)
    
35.         End If
    
36.     Next j
    
37. End Sub

复制代码

香川群子

AVEL 发表于 2012-8-12 17:34
好像之前法师有做过类似的。

呵呵，我的代码，不过是把for……next循环，转化为递归方式进行处理，并适当提高算法效率而已。

和灰袍法师的高级算法，是没法比的。

香川群子

附件代码进一步改进，

可以根据输入n参数自动调整计算方法：
1. 输入n>m，如n=m+1时，计算并列出所有总和=目标值的各种不重复组合结果。
2. 输入n<=m时，仅计算从m个元素中抽取n个数的，总和=目标值的不重复组合结果。

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

复制代码

小花鹿

在学习递归方法之前，我想先知道，在EXCEL应用中递归有什么现实的意义，有什么实际的EXCEL问题用到递归呢？
我见过的帖子好像理论研究的多，解决实际问题的少。

香川群子

小花鹿 发表于 2012-8-14 11:33
在学习递归方法之前，我想先知道，在EXCEL应用中递归有什么现实的意义，有什么实际的EXCEL问题用到递归呢？ ...

递归是一种思路，一种高效算法。


理论上，所有的递归过程，都可以转化为用循环方法解决，
即不用递归也可以做几乎任何事。

而且，递归也不能解决所有的问题，
即，有些问题递归方法无能为力。

因此，递归的实际运用、普及就受到了极大的现实制约。
1. 其实很多人都不懂递归，当然就不会想到要去用递归。
2. 很多人循环方法已经很熟练了，即使能用递归，也会因为习惯而直接写循环代码解决。
3. 递归运用之前，需要好好思考，如何写出不产生遗漏和错误的递归代码。
  bug调整检查是必须的。 这个就比直接写循环要难度大一些。
4. 如果递归层次太多，可能造成堆栈溢出等，限制了使用。



但是，一种类型的递归代码如果写好调试成功以后，
在此基础上的变化将是非常简单、高效的。


所以，学习和运用递归，是很有意思的事。

香川群子

1楼代码加了完整注释，方便有兴趣的人理解、学习。


实际上，由于使用了对原始数据排序，以及递归过程中比对的方法，
既可以排除重复计算结果，还可以大大地提高计算效率……因为不需要遍历所有组合了。