[已解决]33个数中生成不 重复6个数

mmc998

Book1.xlsx1.rar (6.17 KB, 下载次数: 34)

2014-10-5 21:43 上传

点击文件名下载附件 33个数中生成不 重复6个数

最佳答案

月排行榜 / 总排行榜

xdragon

2014-10-7 02:24

1. Dim ttl%, chs%, rnd_array%(), t_array%(), cbn&, irow&, cnt&
   
2. 
   
3. Sub test()
   
4.    ttl = 5: chs = 3
   
5.    cbn = Application.WorksheetFunction.Combin(ttl, chs)
   
6.    irow = Rows.Count
   
7.    If cbn > irow Then ReDim rnd_array%(1 To irow, 1 To chs) Else ReDim rnd_array%(1 To cbn, 1 To chs)
   
8.    ReDim t_array%(1 To chs)
   
9.    Call dgzh(1, 0)
   
10. End Sub
    
11. 
    
12. Sub dgzh(yn%, n%)
    
13.    Dim i%, j%
    
14.    For i = n + 1 To ttl - chs + yn
    
15.        If yn <= chs Then
    
16.           t_array(yn) = i
    
17.           Call dgzh(yn + 1, i)
    
18.        Else
    
19.           cnt = cnt + 1
    
20.           For j = 1 To chs
    
21.              rnd_array(cnt, j) = t_array(j)
    
22.           Next
    
23.           If cnt Mod irow = 0 Or cnt = cbn Then
    
24.               Call array_to_range
    
25.           End If
    
26.           Exit Sub
    
27.        End If
    
28.    Next
    
29. End Sub
    
30. 
    
31. Sub array_to_range()
    
32.     Static shtcnt%
    
33.     shtcnt = shtcnt + 1
    
34.     If Sheets.Count < shtcnt Then Sheets.Add , Sheets(Sheets.Count)
    
35.     Sheets(shtcnt).Cells.Clear
    
36.     Sheets(shtcnt).Range("A1").Resize(cnt, chs) = rnd_array
    
37.     cbn = cbn - irow
    
38.     If cbn > 0 Then
    
39.        ReDim rnd_array(1 To IIf(cbn > irow, irow, cbn), 1 To UBound(rnd_array, 2))
    
40.     Else
    
41.        shtcnt = 0
    
42.        Erase rnd_array
    
43.     End If
    
44.     cnt = 0
    
45. End Sub
    

复制代码

跳转到最佳答案楼层

刀羊

全排列共要百万以上。

mmc998

刀羊 发表于 2014-10-5 22:01
全排列共要百万以上。

是的，能做吗？

su45

33个数，都只用一次？

qh8600

33选6+16选1，福利彩票

mmc998

su45 发表于 2014-10-5 22:28
33个数，都只用一次？

无数次

mmc998

qh8600 发表于 2014-10-5 22:39
33选6+16选1，福利彩票

能做吗

qh8600

mmc998 发表于 2014-10-5 22:42
能做吗

我以前写过，明天帮你写写看，今天太晚了

mmc998

qh8600 发表于 2014-10-5 22:46
我以前写过，明天帮你写写看，今天太晚了

谢谢

xdragon

1. Sub test()
   
2.    Dim ttl%, chs%, re%(), tmp%()
   
3.    ttl = 33: chs = 6
   
4.    ReDim re%(1 To Application.WorksheetFunction.Combin(ttl, chs), 1 To chs)
   
5.    ReDim tmp%(1 To chs)
   
6.    Call dgzh(re, 1, 0, tmp, ttl, chs, 0)
   
7. End Sub
   
8. 
   
9. Sub dgzh(rnd_array, yn%, n%, t_array, ttl%, chs%, cnt&)
   
10.    Dim i%, j%
    
11.    For i = n + 1 To ttl - chs + yn
    
12.        If yn <= chs Then
    
13.           t_array(yn) = i
    
14.           Call dgzh(rnd_array, yn + 1, i, t_array, ttl, chs, cnt)
    
15.        Else
    
16.           cnt = cnt + 1
    
17.           For j = 1 To chs
    
18.              rnd_array(cnt, j) = t_array(j)
    
19.           Next
    
20.           Exit Sub
    
21.        End If
    
22.    Next
    
23. End Sub

复制代码

最终结果在re这个数组里，由于33选6有110多w组合，一次性无法导出到单元格。如果需要请回复哈