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

vbaplus

香川群子 发表于 2013-1-13 23:16
如果有设定个数要求n时，当t=n时即可剪枝退出。
因为以后的计算结果，必定是t>n了。

把递归放在循环里，我可不可以认为你这个是 “双层递归” 模式？

香川群子

vbaplus 发表于 2013-1-14 19:32
恩，通过单步运行，发现了这个特点~
也就是说，只有当一个递归过程完整的执行完毕后，这个过程中产生的一 ...

总之，递归过程能够反复调用自身，以便进入下一层次的深度搜索过程……

而循环保证了每一个元素都能作为节点被经过、被检查、被计算。

…………
因此，最后的结果，可以认为是有选择地（通过剪枝处理提前终止无效枝节）进行了所有元素的全部组合的检查计算。

香川群子

比如，举个计算例子：
101/102/103/104/105 一共5个数，求和范围[300-320]

用我的代码计算结果是10中组合，这正好是所有5个元素的全部组合=combin(5,3)=10

+105+104+101 = 310
+105+104+102 = 311
+105+104+103 = 312
+105+103+101 = 309
+105+103+102 = 310
+105+102+101 = 308
+104+103+101 = 308
+104+103+102 = 309
+104+102+101 = 307
+103+102+101 = 306


重新贴一遍，最好的、功能最全的递归组合计算代码如下：

1. 
   
2. Dim sj, jg(), m%, n%, k&, h&, h2& '定义公用变量，以便递归过程使用
   
3. Sub kagawa_4()   
   
4.     h = [b1]: h2 = [b2]: If h2 > h Then h2 = h2 - h '设定和值范围为B1单元格和B2单元格之间，如B2单元格为空则只考虑=B1单元格值
   
5.     m = [a1].End(4).Row: ' sj0 = [a1].Resize(m)
   
6.     [a1].Resize(m).Sort [a1], 1, , , 2 '原始数据排序
   
7.     sj = [a1].Resize(m, 2): ' [a1].Resize(m) = sj0
   
8.     If [b3] > 0 And [b3] <= m Then n = [b3] Else n = 0 '如果B3单元格为空则计算所有组合，否则仅返回指定个数=n的结果
   
9.    
   
10.     sj(1, 2) = sj(1, 1)
    
11.     For i = 2 To m
    
12.         sj(i, 2) = sj(i - 1, 2) + sj(i, 1) '整理累计和 以便进行次位【累計和】快速剪枝
    
13.     Next
    
14.    
    
15.     ReDim jg(65535, 2): jg(0, 0) = "n": jg(0, 1) = "s": jg(0, 2) = "dgH4: "
    
16.     k = 0: cnt = 0: tms = Timer '初始化
    
17.    
    
18.     Call dgH4(h, "", m + 1, 1) '调用递归过程开始计算直至结束
    
19.    
    
20.     MsgBox "Result: " & k & " Time: " & Format(Timer - tms, "0.000s")
    
21.     If k > 0 And k < 65536 Then [f:h] = "": [f1].Resize(k + 1, 3) = jg
    
22.     If ActiveWorkbook.ActiveSheet.FilterMode = False Then [f1].CurrentRegion.AutoFilter
    
23.     [h1] = "dgH4: " & k
    
24. End Sub
    
25. 
    
26. '下面是递归过程： 逆序递归差値計算、正序検索末位=[r,r+h2]、次位>r+h2时剪枝停止/次位累計和<r时剪枝停止
    
27. Sub dgH4(r, s$, i%, t%)
    
28. '递归过程 r=对于目标和值的递减差值，s=过程的文字结果记录，i=倒序检查位置，t=累计参与计算元素个数
    
29.     Dim j%
    
30.    
    
31.     If n = 0 Or t = n Then
    
32.         For j = 1 To i - 1 '正序検索
    
33.             If r <= sj(j, 1) And sj(j, 1) <= r + h2 Then '正序検索末位范围=[r,r+h2]
    
34.                 k = k + 1 '符合目标和值范围时即可将此结果写入数组
    
35.                 If k < 65536 Then
    
36.                     jg(k, 0) = t
    
37.                     jg(k, 1) = h - r + sj(j, 1)
    
38.                     jg(k, 2) = s & "+" & sj(j, 1)
    
39.                 End If
    
40.             End If
    
41.         Next
    
42.     End If
    
43.     If t = n Then Exit Sub 'n=0时即无个数限制则继续
    
44.    
    
45.     For j = i - 1 To 2 Step -1 '逆序递归
    
46.         If sj(j, 1) < r + h2 Then '次位>r+h2时剪枝停止
    
47.             If sj(j, 2) < r Then
    
48.                 Exit For '次位【累計和】sj(j,2)<r时剪枝停止
    
49.             Else
    
50.                 Call dgH4(r - sj(j, 1), s & "+" & sj(j, 1), j, t + 1) '递归差値計算
    
51.             End If
    
52.         End If
    
53.     Next
    
54. 
    
55. End Sub

复制代码

vbaplus

香川群子 发表于 2013-1-14 20:59
比如，举个计算例子：
101/102/103/104/105 一共5个数，求和范围[300-320]

代码不完整，把公共变量定义搞掉了

香川群子

vbaplus 发表于 2013-1-14 21:33
代码不完整，把公共变量定义搞掉了

嗯，确实如此。

现在已经更新了。又加了几句简单注释。

vbaplus

香川群子 发表于 2013-1-15 09:38
嗯，确实如此。

现在已经更新了。又加了几句简单注释。

之前递加的那个基本上看明白了，但这个又迷糊了，能不能把主要思想说一下？
因为这个没有递归过种记录显示，所以看着比之前的费劲。谢谢你了。

我是决心要把你的这个递归思想吃透的，以后把这个思想利用起来可以解决很多问题。我目前对递归只是最简单的基本应用。

香川群子

vbaplus 发表于 2013-1-16 20:19
之前递加的那个基本上看明白了，但这个又迷糊了，能不能把主要思想说一下？
因为这个没有递归过种记录显 ...

已知m个元素，求各种元素组合的和，符合总和目标值的所有组合。

我的算法思路也是一步一步进化来的。

从最简单的代码，完整但计算效率低开始，
逐步改进，增加代码，加入各种剪枝算法，最后就成了高效，但代码复杂的样子了。


下面开始介绍我的整个思路历程：

第一阶段，为了准确、完整地遍历计算所有组合，想到了二进制算法。

举例，有4个元素a,b,c,d 我发现所有不同组合，正好对应二进制 2^m-1的不同状态组合。
首先，二进制所有状态为：
0000
0001
0010
0011
0100
0101
0110
0111
1000
1001
1010
1011
1100
1101
1110
1111

这2^m=16个二进制状态，完全可以代表所有m个元素的不同抽取组合结果。
即，按照“个十百千”分别代表a,b,c,d的话，那么：
0001,0010,0100,1000 分别代表 a,b,c,d各自出现一次的4个状态。
而 0111,1011,1101,1110分别代表c,b,a、d,b,a、d,c,a、d,c,b、这4种组合。
……
以此类推。

而其中0000没有意义，可以排除。因为它代表了4个元素一个都不出现。

所以，m个元素的所有不同出现组合结果总数=2^m-1

…………

考虑用递归代码，是因为递归计算能够储存中间计算结果，判断反而更快捷。

具体递归过程代码如下：
递归过程之前的整理数据，调用递归过程以及输出计算结果的主过程代码就忽略了。
以后也这样进行，只介绍对于递归算法的改进过程。

Sub dgH(r, s$, i%, t%) '二进制遍历所有元素不同组合的正序dg和計算过程
   Dim j%
     jg(k, 0) = r: jg(k, 1) = s: jg(k, 2) = t: k = k + 1 '这一段代码是记录每一个不同二进制变化的结果
   
    For j = i + 1 To m '循环遍历剩余元素
        Call dgH(r + sj(j, 1), s & "+" & sj(j, 1), j, t + 1) '反复调用进入下一层递归，实现二进制状态变化。
    Next j
   
End Sub

其中sj(j, 1)是当前位置对应元素的数值。即数据数组中对应值
r是求和结果累计数值
s是状态组合的字符串累计结果
j是当前取值位置指针，通过递归传递到下一层，以便开始新一层的遍历循环。
这样做就可以保证所有组合状态都被循环遍历到。
t是抽取元素的个数累计。


用这样的代码，计算结果返回：
+a
+a+b
+a+b+c
+a+b+c+d
+a+b+d
+a+c
+a+c+d
+a+d
+b
+b+c
+b+c+d
+b+d
+c
+c+d
+d

……
呵呵，以上就是第一阶段的思路。

递归实现所有二进制状态的遍历检查，代码简单有效。
（当然这样的算法计算效率是最低的，因为所有的组合，不管有用无用都要遍历一遍。）

香川群子

第2阶段，开始想到了可以剪枝，提前结束，从而提高计算效率。

首先，对于原始数据，必须按照从小到大排序整理。（代码略）
接下了递归过程就变成这个样子，循环中增加了一句代码。

Sub dgH1(r, s$, i%, t%) '正序dg和計算、r+次位>h停止
   Dim j%
   
      If r = h Then jg(k, 0) = s : k = k + 1 '满足和条件时记录结果
     
    For j = i + 1 To m
        If r + sj(j, 1) > h Then Exit For '如果现在的累计和再加上下一个元素将大于目标和值时剪枝退出。
        Call dgH1(r + sj(j, 1), s & "+" & sj(j, 1), j, t + 1)
      Next j

End Sub

其中，h为目标和值。

香川群子

第3阶段，对于剪枝算法，又有了新的想法……

累计和最后一位可以提前计算得到而进行比对，而不需要进入下一层递归计算后再比较。
这样就简化、减少了一层递归计算，对于算法效率的提高也是功不可没!

Sub dgH2(r, s$, i%, t%) '正序dg和計算、正序検索末位=[h,h2]/r+次位>h2停止
    Dim j%

        For j = i + 1 To m '提前进行末位检查
            If h = r + sj(j, 1) Then
                jg(k, 0) = s & "+" & sj(j, 1) '找到相等时就可以输出结果了
                k = k + 1
            ElseIf r + sj(j, 1) > h Then
                Exit For '检查比对到和值将要大于目标和值时即可剪枝退出
            End If
        Next
   
    For j = i + 1 To m - 1
        If r + sj(j, 1) + sj(j + 1, 1) > h Then
            Exit For '如果将要得到的和会大于目标和值，就没有计算必要了可以提前剪枝退出
        Else
            Call dgH2(r + sj(j, 1), s & "+" & sj(j, 1), j, t + 1) '进入下一层次递归
        End If
    Next

End Sub

香川群子

第4阶段

首先，递归计算顺序，我改为倒序检查计算，即从最大数开始往下递减。
同时，对于已经排序好的原始数据，我可以事先整理得到每一个位置的累计和，
即对于原始数据1,2,3,4,5,6来说，累计和为1,3,6,10,15,21

这样，当我倒序进行求和计算，发现在某一个元素位置，如果剩余数全部加上也不够时，
当然就可以提前剪枝退出了。


这个算法，又大大地提高了整体计算效率。


Sub dgH3(r, s$, i%, t%) '逆序dg和計算、正序検索末位=[h,h2]、r+次位>h2停止/r+次位累計和<h停止
    Dim j%

    For j = 1 To i - 1 '提前进行末位计算比对，减少递归层次
        If h = r + sj(j, 1) Then
              jg(k, 0) = s & "+" & sj(j, 1)
             k = k + 1
        ElseIf r + sj(j, 1) > h Then
            Exit For
        End If
    Next
   
    For j = j - 1 To 2 Step -1 '倒序进行递归循环计算
        If r + sj(j, 1) > h Then
            Exit For '累计总和大于目标和值是剪枝退出
        Else
            If r + sj(j, 2) < h Then
                Exit For '累计总和加上所有剩余数也不够时提前剪枝退出
            Else 'If Not r + sj(j, 2) < h Then
                Call dgH3(r + sj(j, 1), s & "+" & sj(j, 1), j, t + 1)
            End If
        End If
    Next

End Sub