[已解决]请教组合统计问题

vfla

说明:如图,
1.如表格,D1到O1为12个数字
2.A列为场次,B列为每场出现的数字

3.从D1到O1的12个数中每取5个为一组,一共有792个组合(12345,12346,12347...8 9 10 11 12)
比如,先取D1到H1的5个为Z组(12345)
对照每场出现的数字,Z组里的5个数在第1到第6连续6场都不出现,在第7场出席了,这时6就称为Z组的遗漏值
同理,红色标记的6 8 7 3都是Z组的遗漏值

第一步:求出Z组的最大遗漏值
第二步:分别求出792个组合的最大遗漏值
第三步:从792个最大遗漏值中选出最小的值并标记它所对应的组合
也就是找出最大遗漏值最小的组合（5个数字）
(以上仅为说明,只要能求出最终结果即可)

需要结果:
求最大遗漏值最小的组合(把5个数字导出到记事本里 E:\001.txt)

                 <:万分感谢:)
组合统计.rar (7.25 KB, 下载次数: 21)

2012-2-1 22:02 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

香川群子

2012-2-2 12:54

蓝桥老师的代码，总是太过复杂。

1. Sub zz()
   
2.     tms = Timer
   
3.    
   
4.     Dim a%, b%, c%, d%, e%, i%, k%, m%, n%
   
5.     Dim yl%, zdyl%, zxzdyl%, zxzdylxh$, s$
   
6.    
   
7. '    Sheet1.Activate
   
8.     arr = [a4].Resize([a65536].End(3).Row - 3, 3)
   
9.     n = UBound(arr)
   
10.     zxzdyl = n
    
11.    
    
12.     'm = WorksheetFunction.Combin(12, 5)
    
13.     m = 792
    
14.     ReDim brr$(m)
    
15.     For a = 1 To 8
    
16.         For b = a + 1 To 9
    
17.             For c = b + 1 To 10
    
18.                 For d = c + 1 To 11
    
19.                     For e = d + 1 To 12
    
20.                         k = k + 1
    
21.                         brr(k) = a & ";" & b & ";" & c & ";" & d & ";" & e
    
22.                         
    
23.                         yl = 0: zdyl = 0
    
24.                         For i = 2 To n
    
25.                             If InStr(";" & brr(k) & ";", ";" & arr(i, 2) & ";") Then
    
26.                                 If yl > zdyl Then zdyl = yl
    
27.                                 yl = 0
    
28.                             Else
    
29.                                 yl = yl + 1
    
30.                             End If
    
31.                         Next
    
32.                         
    
33.                         If zdyl < zxzdyl Then
    
34.                             zxzdyl = zdyl
    
35.                             zxzdylxh = k
    
36.                         ElseIf zdyl = zxzdyl Then
    
37.                             zxzdylxh = zxzdylxh & ";" & k
    
38.                         End If
    
39.                         
    
40.                         If zdyl > zdzdyl Then
    
41.                             zdzdyl = zdyl
    
42.                             zdzdylxh = k
    
43.                         ElseIf zdyl = zdzdyl Then
    
44.                             zdzdylxh = zdzdylxh & ";" & k
    
45.                         End If
    
46.     Next e, d, c, b, a
    
47.    
    
48.     x = Split(zxzdylxh, ";")
    
49.     s = "Min of MaxLeakNum is : " & zxzdyl & vbCr & "Combin Detail as below : "
    
50.     For i = 0 To UBound(x)
    
51.         s = s & vbCr & brr(x(i))
    
52.     Next
    
53.    
    
54.     x = Split(zdzdylxh, ";")
    
55.     s = s & vbCr & vbCr & "Max of MaxLeakNum is : " & zdzdyl & vbCr & "Combin Detail as below : "
    
56.     For i = 0 To UBound(x)
    
57.         s = s & vbCr & brr(x(i))
    
58.     Next
    
59.    
    
60.     MsgBox s & vbCr & vbCr & Format(Timer - tms, "0.000s")
    
61.    
    
62. End Sub
    
63. 
    

复制代码

代码运行后，同时统计并列出：

最大遗漏的最小值=1，有2组： 6,7,8,9,11 和 6,8,9,11,12

最大遗漏的最大值=15，有1组： 1,3,4,5,10


运行速度比蓝桥代码快1倍。

跳转到最佳答案楼层

vfla

各位大大帮忙看看吧
数据量大慢点没事
晚上睡觉启动,第二天早上起来能出结果就可以

蓝桥玄霜

1. Sub yy()
   
2. Dim i&, Myr&, Arr, r%, Arr1(), br, aa, zd
   
3. Dim j&, x&, y&, z&, yl(), rr%, zdyl, n&
   
4. Sheet1.Activate
   
5. For i = 1 To 8
   
6.     For j = i + 1 To 9
   
7.         For x = j + 1 To 10
   
8.             For y = x + 1 To 11
   
9.                 For z = y + 1 To 12
   
10.                     r = r + 1
    
11.                     ReDim Preserve Arr1(1 To r)
    
12.                     Arr1(r) = i & " " & j & " " & x & " " & y & " " & z
    
13.                 Next
    
14.             Next
    
15.         Next
    
16.     Next
    
17. Next
    
18. Myr = [a65536].End(xlUp).Row
    
19. Arr = Range("a4:b" & Myr)
    
20. ReDim br(1 To UBound(Arr))
    
21. ReDim zdyl(1 To r)
    
22. ReDim zd(1 To r)
    
23. For i = 1 To r
    
24.     aa = Split(Arr1(i)): rr = 0: n = 0
    
25.     For j = 1 To UBound(Arr)
    
26.         For x = 1 To 5
    
27.             If Val(aa(x - 1)) = Arr(j, 2) Then
    
28.                 br(j) = 0
    
29.                 If j <> 1 Then
    
30.                     rr = rr + 1
    
31.                     ReDim Preserve yl(1 To rr)
    
32.                     yl(rr) = br(j - 1): n = 0: GoTo 100
    
33.                 End If
    
34.             Else
    
35.             End If
    
36.         Next
    
37.             If j <> UBound(Arr) And j <> 1 Then
    
38.                 n = n + 1
    
39.                 br(j) = n
    
40.             ElseIf j <> 1 Then
    
41.                 rr = rr + 1
    
42.                 ReDim Preserve yl(1 To rr)
    
43.                 yl(rr) = n + 1
    
44.             End If
    
45. 100:
    
46. Next
    
47.     zdyl(i) = Application.Max(yl)
    
48.     zd(i) = Arr1(i)
    
49. Next
    
50. zx = Application.Min(zdyl)
    
51. For i = 1 To r
    
52.     If zdyl(i) = zx Then MsgBox "最大遗漏值的最小值是： " & zx & vbCrLf & "最大遗漏值的最小组合是： " & zd(i): Exit For
    
53. Next
    
54. End Sub
    

复制代码

蓝桥玄霜

请见附件。

香川群子

蓝桥老师的代码，总是太过复杂。

1. Sub zz()
   
2.     tms = Timer
   
3.    
   
4.     Dim a%, b%, c%, d%, e%, i%, k%, m%, n%
   
5.     Dim yl%, zdyl%, zxzdyl%, zxzdylxh$, s$
   
6.    
   
7. '    Sheet1.Activate
   
8.     arr = [a4].Resize([a65536].End(3).Row - 3, 3)
   
9.     n = UBound(arr)
   
10.     zxzdyl = n
    
11.    
    
12.     'm = WorksheetFunction.Combin(12, 5)
    
13.     m = 792
    
14.     ReDim brr$(m)
    
15.     For a = 1 To 8
    
16.         For b = a + 1 To 9
    
17.             For c = b + 1 To 10
    
18.                 For d = c + 1 To 11
    
19.                     For e = d + 1 To 12
    
20.                         k = k + 1
    
21.                         brr(k) = a & ";" & b & ";" & c & ";" & d & ";" & e
    
22.                         
    
23.                         yl = 0: zdyl = 0
    
24.                         For i = 2 To n
    
25.                             If InStr(";" & brr(k) & ";", ";" & arr(i, 2) & ";") Then
    
26.                                 If yl > zdyl Then zdyl = yl
    
27.                                 yl = 0
    
28.                             Else
    
29.                                 yl = yl + 1
    
30.                             End If
    
31.                         Next
    
32.                         
    
33.                         If zdyl < zxzdyl Then
    
34.                             zxzdyl = zdyl
    
35.                             zxzdylxh = k
    
36.                         ElseIf zdyl = zxzdyl Then
    
37.                             zxzdylxh = zxzdylxh & ";" & k
    
38.                         End If
    
39.                         
    
40.                         If zdyl > zdzdyl Then
    
41.                             zdzdyl = zdyl
    
42.                             zdzdylxh = k
    
43.                         ElseIf zdyl = zdzdyl Then
    
44.                             zdzdylxh = zdzdylxh & ";" & k
    
45.                         End If
    
46.     Next e, d, c, b, a
    
47.    
    
48.     x = Split(zxzdylxh, ";")
    
49.     s = "Min of MaxLeakNum is : " & zxzdyl & vbCr & "Combin Detail as below : "
    
50.     For i = 0 To UBound(x)
    
51.         s = s & vbCr & brr(x(i))
    
52.     Next
    
53.    
    
54.     x = Split(zdzdylxh, ";")
    
55.     s = s & vbCr & vbCr & "Max of MaxLeakNum is : " & zdzdyl & vbCr & "Combin Detail as below : "
    
56.     For i = 0 To UBound(x)
    
57.         s = s & vbCr & brr(x(i))
    
58.     Next
    
59.    
    
60.     MsgBox s & vbCr & vbCr & Format(Timer - tms, "0.000s")
    
61.    
    
62. End Sub
    
63. 
    

复制代码

代码运行后，同时统计并列出：

最大遗漏的最小值=1，有2组： 6,7,8,9,11 和 6,8,9,11,12

最大遗漏的最大值=15，有1组： 1,3,4,5,10


运行速度比蓝桥代码快1倍。

香川群子

蓝桥代码中第24-46行，太过复杂。

aa = Split(Arr1(i)): rr = 0: n = 0

    For j = 1 To UBound(Arr)

        For x = 1 To 5

            If Val(aa(x - 1)) = Arr(j, 2) Then

                br(j) = 0

                If j <> 1 Then

                    rr = rr + 1

                    ReDim Preserve yl(1 To rr)

                    yl(rr) = br(j - 1): n = 0: GoTo 100

                End If

            Else

            End If

        Next

            If j <> UBound(Arr) And j <> 1 Then

                n = n + 1

                br(j) = n

            ElseIf j <> 1 Then

                rr = rr + 1

                ReDim Preserve yl(1 To rr)

                yl(rr) = n + 1

            End If

100:

Next


比较部分，
我只用这几句就解决了：

yl = 0: zdyl = 0
For i = 2 To n
    If InStr(";" & brr(k) & ";", ";" & arr(i, 2) & ";") Then
        If yl > zdyl Then zdyl = yl
        yl = 0
    Else
        yl = yl + 1
    End If
Next

香川群子

组合得到了5个代码，已经合并了，

却还要用split去拆分以后，一个一个去比较……效率就低多了。

我用instr函数，一次比较就够了。

vfla

终于看见两位大大露面了...从初一开始到昨晚我一直在搜索"组合" "遗漏"相关帖子学习
对两位大大的名字印象深刻啊[em17]
感谢蓝桥玄霜版主[em17]
感谢香川群子[em17]

vfla

其实今天我一直在测试两位老师的代码
因为自己实际运用数据量很大,再加上自己的VBA基础相当溥弱,测试起来比较慢
如遇到自己无法解决的问题再来向两位老师请教[em27]

vfla

继续测试[em38][em38][em38]