[已解决]请教列组合问题

yvll

请教列组合问题，就是：
1、在EJ145中选择0，则由EI145要求的列数组合中的每行至少有一个单元格有“有”字。
2、在EJ145中选择大于0的数字，则由EI145要求的列数组合中没有”有“字的行不得大于EJ145规定的行数。
谢谢！
请教列组合问题.rar (14.38 KB, 下载次数: 9)

2014-8-13 19:19 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

香川群子

2014-8-13 20:45

因为组合4、5、6都有 错误值=0时的解。

还好，几秒钟就能算完。

1. 
   
2. Dim a&(), b$(), c&(), AC&, m&, n&, k&, z&, cnt&, tms# '定义公用变量
   
3. Sub kagawa()
   
4.     Dim i&, j&
   
5.     tms = Timer
   
6.    
   
7.     ar = [CN146:EH240]
   
8.     ReDim a&(1 To 95, 1 To 47)
   
9.     For i = 1 To 95
   
10.         For j = 1 To 47
    
11.             If ar(i, j) = "有" Then a(i, j) = 1 '整理原始数据以便快速检查
    
12.         Next
    
13.     Next
    
14.     ReDim b$(100) '存放结果的数组b初始化
    
15.    
    
16.     m = 47: n = [EI145]: z = [EJ145]
    
17.     AC = WorksheetFunction.Combin(m, n)
    
18.     ReDim c&(1 To n)
    
19.     k = 0: cnt = 0: Call dgZH("", 0, 1) '调用递归组合算法
    
20.     Application.StatusBar = Format(Timer - tms, "0.000s ") & cnt & " / " & Format(k, "#,##0")
    
21.    
    
22.     If cnt Then [EL145].CurrentRegion = "": [EL145].Resize(cnt) = WorksheetFunction.Transpose(b)
    
23.     MsgBox Format(Timer - tms, "0.000s ") & Format(cnt, "#,##0")
    
24. End Sub
    
25. 
    
26. Sub dgZH(s$, i&, t&) '递归组合计算过程
    
27.     Dim j&
    
28.     For j = i + 1 To m - n + t
    
29.         c(t) = j
    
30.         If t < n Then
    
31.             Call dgZH(s & "," & j, j, t + 1)
    
32.         Else
    
33.             k = k + 1
    
34.             If Chk(n) Then
    
35.                 b(cnt) = Mid(s & "," & j, 2)
    
36.                 cnt = cnt + 1: If cnt > UBound(b) Then ReDim Preserve b$(cnt + 100)
    
37.                 Application.StatusBar = Format(Timer - tms, "0.000s ") & cnt & Format(k / AC, " 0.0% ") & Format((AC / k - 1) * (Timer - tms), " 0.0s")
    
38.             End If
    
39.         End If
    
40.     Next
    
41. End Sub
    
42. 
    
43. Function Chk(t&) As Boolean '检查过程
    
44.     Dim i&, j&, r&
    
45.     Chk = True: r = z
    
46.     For i = 1 To 95
    
47.         For j = 1 To n
    
48.             If a(i, c(j)) Then Exit For
    
49.         Next
    
50.         If j > n Then If r Then r = r - 1 Else Chk = False: Exit Function
    
51.     Next
    
52. End Function
    

复制代码

寻找相同列.rar (26.88 KB, 下载次数: 14)

2014-8-13 20:59 上传

点击文件名下载附件

跳转到最佳答案楼层

香川群子

楼主这是要干啥呢？彩票？！

如果选5
那么要检查的列数组合=Combin(47,5)=1,533,939
没一种组合可能需要检查 240-145=95行。

估计每次计算至少5分钟。呵呵。

这儿有肥猫

香川群子 发表于 2014-8-13 19:42
楼主这是要干啥呢？彩票？！

如果选5

哇,香川大神,崇拜已久,终见真身{:2812:}

yvll

香川群子 发表于 2014-8-13 19:42
楼主这是要干啥呢？彩票？！

如果选5

蒙您眷顾，非常感谢
，知道您有能力，请帮助，因为有EI145和EJ145两个选项，实际使用中可以减少时间。

香川群子

因为组合4、5、6都有 错误值=0时的解。

还好，几秒钟就能算完。

1. 
   
2. Dim a&(), b$(), c&(), AC&, m&, n&, k&, z&, cnt&, tms# '定义公用变量
   
3. Sub kagawa()
   
4.     Dim i&, j&
   
5.     tms = Timer
   
6.    
   
7.     ar = [CN146:EH240]
   
8.     ReDim a&(1 To 95, 1 To 47)
   
9.     For i = 1 To 95
   
10.         For j = 1 To 47
    
11.             If ar(i, j) = "有" Then a(i, j) = 1 '整理原始数据以便快速检查
    
12.         Next
    
13.     Next
    
14.     ReDim b$(100) '存放结果的数组b初始化
    
15.    
    
16.     m = 47: n = [EI145]: z = [EJ145]
    
17.     AC = WorksheetFunction.Combin(m, n)
    
18.     ReDim c&(1 To n)
    
19.     k = 0: cnt = 0: Call dgZH("", 0, 1) '调用递归组合算法
    
20.     Application.StatusBar = Format(Timer - tms, "0.000s ") & cnt & " / " & Format(k, "#,##0")
    
21.    
    
22.     If cnt Then [EL145].CurrentRegion = "": [EL145].Resize(cnt) = WorksheetFunction.Transpose(b)
    
23.     MsgBox Format(Timer - tms, "0.000s ") & Format(cnt, "#,##0")
    
24. End Sub
    
25. 
    
26. Sub dgZH(s$, i&, t&) '递归组合计算过程
    
27.     Dim j&
    
28.     For j = i + 1 To m - n + t
    
29.         c(t) = j
    
30.         If t < n Then
    
31.             Call dgZH(s & "," & j, j, t + 1)
    
32.         Else
    
33.             k = k + 1
    
34.             If Chk(n) Then
    
35.                 b(cnt) = Mid(s & "," & j, 2)
    
36.                 cnt = cnt + 1: If cnt > UBound(b) Then ReDim Preserve b$(cnt + 100)
    
37.                 Application.StatusBar = Format(Timer - tms, "0.000s ") & cnt & Format(k / AC, " 0.0% ") & Format((AC / k - 1) * (Timer - tms), " 0.0s")
    
38.             End If
    
39.         End If
    
40.     Next
    
41. End Sub
    
42. 
    
43. Function Chk(t&) As Boolean '检查过程
    
44.     Dim i&, j&, r&
    
45.     Chk = True: r = z
    
46.     For i = 1 To 95
    
47.         For j = 1 To n
    
48.             If a(i, c(j)) Then Exit For
    
49.         Next
    
50.         If j > n Then If r Then r = r - 1 Else Chk = False: Exit Function
    
51.     Next
    
52. End Function
    

复制代码

寻找相同列.rar (26.88 KB, 下载次数: 14)

2014-8-13 20:59 上传

点击文件名下载附件

香川群子

附件有更新，第2选项也加入了……意外地很容易。


计算速度实际只要数秒……因为很多列组合错误结果很容易就被排除了，所以实际计算量很小。

刚确认了一下，以5为例，实际检查行的次数=21,177,524  即平均每个组合大约检查13-14行左右。

yvll

香川群子 发表于 2014-8-13 20:45
因为组合4、5、6都有 错误值=0时的解。

还好，几秒钟就能算完。

您太伟大了，非常感谢！
如果您有时间，请您把EJ145的功能加上。

yvll

香川群子 发表于 2014-8-13 21:01
附件有更新，第2选项也加入了……意外地很容易。

万分万分感谢您，您的水平非常高，无论是在EH还是在这里您的帖子经常看，这次能得到您的帮助，非常幸运。再次感谢您！

香川群子

在EH 发表于 2014-8-13 19:22:53 ……

呵呵，这里是原发啊。

yvll

香川群子 发表于 2014-8-13 21:31
在EH 发表于 2014-8-13 19:22:53 ……

呵呵，这里是原发啊。

香川群子您好，还是这个问题我改变了一下提问，请您抽时间帮助一下。谢谢您。
改变的内容在附件中。
寻找相同列.rar (16.15 KB, 下载次数: 0)

2015-1-21 14:55 上传

点击文件名下载附件