抛块砖--遍历组合的一种算法

chenzyyysl

问题来自http://club.excelhome.net/viewth ... p;extra=&page=1
我以前也遇见过类似的，下面是我的解法，也不知是不是以前就有这样做的。

zpy2

数据多的话，我一般用 一个联合查询产生一个笛卡尔乘积，然后用sql统计的。

如：显示>30的组合
SELECT [sheet1].[f1] & [sheet1_1].[f1] AS f
FROM Sheet1, Sheet1 AS Sheet1_1
WHERE ([sheet1].[f1] & [sheet1_1].[f1])>30;

zhaoxuie

你们懂VBA，真好！

wangfengcpa

楼主的算法很新颖。

aidixiao

很实用，谢谢分享。

香川群子

Sub 组合求和()
    Dim a
    ReDim b(65536)
    r = [b2] '所求和放入B2单元格中
   
    a = Application.WorksheetFunction.Transpose(Range([a2], [a2].End(4)))
    '组合对象数组放入A2开始的A列单元格中，不要留空格
   
    l = UBound(a)
   
    For i = 1 To 2 ^ l - 1
        t = i
        k = 0
        s = 0
        f = "="
        Do Until t = 0
            k = k + 1
            If t Mod 2 = 1 Then
                s = s + a(k)
                f = f & "+" & a(k)
            End If
            t = t \ 2
        Loop
        If s = r Then
            n = n + 1
            b(n) = r & Replace(f, "=+", "=")
        End If
    Next
    ReDim Preserve b(n)
    b(0) = "组合结果"
    [c1].Resize(UBound(b) + 1, 1) = Application.WorksheetFunction.Transpose(b)
   
End Sub

[ 本帖最后由 香川群子 于 2010-7-11 21:18 编辑 ]

chenzyyysl

好多是我没用过的，要好好学习了。我只会用函数解决大部分难题，用VBA做循环等简单的处理。

香川群子

改用递归方法计算，比原来的二进制遍历计算要快很多。

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]
   
5.     sj0 = [a2].Resize(m): [a2].Resize(m).Sort [a2], 1, , , 2
   
6.     sj = [a2].Resize(m)
   
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)
   
10.     k = 1: cnt = 0
    
11. '    ReDim jg2(65536, 0)
    
12.    
    
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.    
    
26.     p = Split(s, "+")
    
27.     For j = 1 To UBound(p)
    
28.         jg(0, j) = p(j)
    
29.     Next
    
30.    
    
31.     If r = h Then
    
32.         If n > m Or t = n Then
    
33.             For j = 1 To UBound(p)
    
34.                 jg(k, j) = p(j)
    
35.             Next
    
36.             For j = UBound(p) + 1 To n
    
37.                 jg(k, j) = ""
    
38.             Next
    
39.             jg(k, 0) = "=" & Mid(s, 2)
    
40.             k = k + 1
    
41.         End If
    
42.         Exit Sub
    
43.     End If
    
44.     If t = n Then Exit Sub 'n>m → go on
    
45.    
    
46.     For j = i + 1 To m
    
47.         If r + sj(j, 1) > h Then Exit For
    
48.         If CStr(sj(j, 1)) <> jg(0, t + 1) Then
    
49.             If t < n - 1 Then jg(0, t + 2) = ""
    
50.             Call bcfhdg(s & "+" & sj(j, 1), r + sj(j, 1), j, t + 1)
    
51.         End If
    
52.     Next j
    
53. End Sub
    

复制代码

香川群子

念一环 发表于 2012-8-15 12:14
多次测试，两个程序结果基本上不一样，发现第一段程序结果有重复的，可能是这个原因。

对，第一段程序，是我两年前写的代码，

原理很简单，就是把序号用二进制转换成0、1的结果，
然后0无效、1有效，这样遍历就得到各种完全不同的组合。

比如，3个元素a、b、c，组合结果总数=2^3=8
即：
序号 二进制   对应结果
0       000      0 + 0 + 0
1       001      0 + 0 + a
2       010      0 + b + 0
3       011      0 + b + a
4       100      c + 0 + 0
5       101      c + 0 + a
6       110      c + b + 0
7       111      c + b + a


但是，如果原始数据中有重复，比如a=b时，结果就会有重复。
如： c+b 和 c+a是一样的。


……
正因为如此，我现在用递归方法写的代码，就加入了鉴别和剔除重复数据的代码。

因此计算结果较少，但反而更准确。

香川群子

8楼代码和附件又有更新，目标总和由单一值改为和值目标范围。

并且增加了完整注释。 请看下面链接：
http://club.excelhome.net/thread-905407-1-1.html