[已解决]如何用ＶＢＡ从1-49个数中取两小组24个数生成多组不同的组合

pqp888

从1-49个数中取两小组24个数生成一个大组合，两小组的数不能重复，Ｂ列中的每行组合也不能有相同，Ｃ列中的每行组合也不能有相同，以“,”号结束，要生成多少行可自定，不知哪位高手老师可用ＶＢＡ帮我做到，要求请看附件。谢谢。

最佳答案

月排行榜 / 总排行榜

grf1973

2016-2-26 15:47

请看附件。

跳转到最佳答案楼层

grf1973

=（49选24）*（25选1）=1580132580471900种可能。（1580万亿）

grf1973

如果只要生成有限种组合数，比较简单。

1. Sub tt()
   
2.     Dim arr(1 To 49), N&, L%, x1$, x2$
   
3.     For i = 1 To 49: arr(i) = i: Next
   
4.     N = InputBox("请输入需要生成的组合数", , 20)
   
5.     ReDim brr(1 To N, 2)
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     For k = 1 To N
   
8.         L = 49
   
9.         crr = arr
   
10.         x1 = "": x2 = ""
    
11.         For i = 1 To 48
    
12.             p = Int(Rnd * L + 1)
    
13.             tmp = crr(p)
    
14.             crr(p) = crr(L)
    
15.             L = L - 1
    
16.             If L >= 25 Then x1 = x1 & "," & tmp Else x2 = x2 & "," & tmp
    
17.         Next
    
18.         If Not d.exists(x1 & x2) Then
    
19.             d(x1 & x2) = ""
    
20.             brr(k, 0) = k
    
21.             brr(k, 1) = Mid(x1, 2)
    
22.             brr(k, 2) = Mid(x2, 2)
    
23.         Else
    
24.             k = k - 1
    
25.         End If
    
26.     Next
    
27.     [a:c].ClearContents
    
28.     [a1].Resize(N, 3) = brr
    
29. End Sub
    

复制代码

pqp888

grf1973 发表于 2016-2-26 13:57
如果只要生成有限种组合数，比较简单。

谢谢老师，我看了，基本上是可以了，但我要相隔一行排列和最后哪个数也要以豆号结束，还望老师修正下。

grf1973

请看附件。

pqp888

grf1973 发表于 2016-2-26 15:47
请看附件。

可以了，谢谢老师。

pqp888

grf1973 发表于 2016-2-26 15:47
请看附件。

老师您好，这次想请你帮我把这个从1-49个数中取两小组24个数生成不同的组合改为生成23个数生成不同的组合，望您能在百忙中能抽点时间帮帮我，先谢谢!

grf1973

每组个数用M控制，以后自己改就行了。

1. Sub tt()
   
2.     Dim arr(1 To 49), N&, L%, x1$, x2$, M%
   
3.     For i = 1 To 49: arr(i) = i: Next
   
4.     N = InputBox("请输入需要生成的组合数", , 20)
   
5.     M = 23
   
6.     ReDim brr(1 To 2 * N, 2)
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     For k = 1 To N
   
9.         L = 49
   
10.         crr = arr
    
11.         x1 = "": x2 = ""
    
12.         For i = 1 To 2 * M
    
13.             p = Int(Rnd * L + 1)
    
14.             tmp = crr(p)
    
15.             crr(p) = crr(L)
    
16.             L = L - 1
    
17.             If L >= 49 - M Then x1 = x1 & tmp & "," Else x2 = x2 & tmp & ","
    
18.         Next
    
19.         If Not d.exists(x1 & x2) Then
    
20.             d(x1 & x2) = ""
    
21.             brr(2 * k - 1, 0) = k
    
22.             brr(2 * k - 1, 1) = x1
    
23.             brr(2 * k - 1, 2) = x2
    
24.         Else
    
25.             k = k - 1
    
26.         End If
    
27.     Next
    
28.     [a:c].ClearContents
    
29.     [a1].Resize(2 * N, 3) = brr
    
30. End Sub

复制代码

pqp888

grf1973 发表于 2016-3-31 16:16
每组个数用M控制，以后自己改就行了。

谢谢