如何将1-49个数随机分组

qwasd3

1至49个数，按8组分，前7组每组6个数，最后一组7个数，每组数是随机的均是从1-49个数随机组合的不重复数。
谢谢！

maditate

什么叫“从1-49个数随机组合的不重复数。”

楼主的意思是不是从49个不重复数中随机抽取并分成8组。有点绕，换种说法。有1到49个不重复数，先乱序排列，再分成8组，1到6个数为第一组，7到12个数为第二组……

ghostjiao

随机生成选择数据

qwasd3

maditate 发表于 2014-7-12 19:14
什么叫“从1-49个数随机组合的不重复数。”

楼主的意思是不是从49个不重复数中随机抽取并分成8组。有点绕 ...

这样说也地，反正就是1到49个数，随机分成8组。

qwasd3

ghostjiao 发表于 2014-7-12 19:25
随机生成选择数据

你好，这个符合我的要求，能否加下注释，学习一下，谢谢！

1. Sub 分组()  
   
2.     Dim arr, i%, j%, k%, brr(1 To 100, 1 To 8), temp, RndNum%, n%
   
3.     arr = Sheet1.Range("A1").CurrentRegion
   
4.     If UBound(arr) Mod 8 = 0 Then n = UBound(arr) \ 8 Else n = UBound(arr) \ 8 + 1
   
5.     VBA.Randomize
   
6.     For i = 1 To n
   
7.         For j = 8 To 1 Step -1
   
8.             k = k + 1
   
9.             If k <= UBound(arr) Then
   
10.                 RndNum = Int(Rnd * (UBound(arr) - k + 1)) + 1
    
11.                 brr(i, j) = arr(RndNum, 1)
    
12.                 temp = arr(RndNum, 1)
    
13.                 arr(RndNum, 1) = arr(UBound(arr) - k + 1, 1)
    
14.                 arr(UBound(arr) - k + 1, 1) = temp
    
15.             End If
    
16.         Next
    
17.     Next
    
18.     Range("C1").Resize(n, 8) = brr
    
19. End Sub

复制代码

bluexuemei

1. Sub t1()
   
2. '须安装ACTIVERUBY.才能运行,下载地址  http://www.artonx.org/data/asr/Ruby-2.1.msi
   
3. Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
   
4. arr = ojs.eval("a=[*1..49].shuffle;b=[6,6,6,6,6,6,6,7];b.map(&a.method(:shift)).map{|x|x<<nil}")
   
5. [e2].Resize(UBound(arr) + 1, UBound(arr, 2) + 1) = arr
   
6. Set ojs = Nothing
   
7. 'Stop
   
8. End Sub

复制代码

香川群子

总计有组合数：
k=1203225027094065555165204440308898611200
Combin(49,7)=85900584
Combin(42,6)=5245786
Combin(36,6)=1947792
Combin(30,6)=593775
Combin(24,6)=134596
Combin(18,6)=18564
Combin(12,6)=924


如果组间不分顺序，则组合数要少一点：
k=238735124423425705389921515934305280
Combin(49,7)=85900584
Combin(41,5)=749398
Combin(35,5)=324632
Combin(29,5)=118755
Combin(23,5)=33649
Combin(17,5)=6188
Combin(11,5)=462

呵呵。

treenewbee

1.     Sub 分组()
   
2.         Dim arr, i As Long, brr(7) As String
   
3.         arr = [a1:a49]
   
4.         [b1].Resize(49) = "=rand()"
   
5.         [a:b].Sort [b1]
   
6.         For i = 0 To 7
   
7.         brr(i) = Chr(i - 23847) & Join(WorksheetFunction.Transpose(Cells(i * 6 + 1, 1).Resize(6 + i \ 7)), ",")
   
8.         Next
   
9.         [a1:a49] = arr
   
10.         [b:b] = ""
    
11.         MsgBox Join(brr, vbCrLf)
    
12.     End Sub
    

复制代码

香川群子

qwasd3 发表于 2014-7-14 09:24
你好，这个符合我的要求，能否加下注释，学习一下，谢谢！

3楼代码的算法，本质上就是【数组洗牌法】了。代码挺不错的。


考虑到通用性，参数可以输入，代码修改为：

1. Sub test()
   
2.     m = InputBox("请输入分组排序最大数 m=", "Rand Group", 49) 'm为任意正整数
   
3.     ReDim a(1 To m) '定义数组a存放1-m各个数值
   
4.     For i = 1 To m
   
5.         a(i) = i
   
6.     Next
   
7.    
   
8.     k = InputBox("请输入分组的组数 k=", "Rand Group", 8) 'k为<m的正整数
   
9.     n = m \ k '计算平均分组以后每组基准个数n。 例如 49/8=6.125取整后=6
   
10.     ReDim b(1 To n + 1, 1 To k) '定义输出结果的数组b 行比n大1，列=分组数k
    
11. 
    
12.     Randomize '随机种子初始化   
    
13.     For j = 1 To k '遍历各列 计算各个分组
    
14.         For i = 1 To n '在每一组中计算1-n个数的随机不重复序号
    
15.             p = p + 1 '数据数组a中当前位置p+1
    
16.             r = Int(Rnd * m) + p '从剩余数m中任选一个位置 加上当前位置即为实际不重复的随机位置
    
17.             m = m - 1 '剩余数-1  【每次只从剩余数m中随机抽取第r个、保证已被抽取的p个不会被重复抽取】
    
18.            't = a(r): a(r) = a(p): a(p) = t: b(i, j) = t '如数组a需要反复使用，则需三次交换
    
19.            '本题只需如下两句即可 (不用返回数组a)
    
20.             b(i, j) = a(r)  '本组j列的第i行 写入本次抽取得到的不重复随机数a(r)
    
21.             a(r) = a(p)    '已被抽取掉数据的a(r)位置 交换写入未被抽取的当前p位置值a(p)
    
22.             'a(p) = b(i, j)  '如只需抽取一次则抽过的数a(r)不用返回数组a的p位置
    
23.         Next
    
24.     Next
    
25.     '到这里 1-k组的平均n个数都已随机抽取完毕，接下来处理多余的零数
    
26. 
    
27.     If m > 0 Then '如果不是恰好整数，有多余零数时：
    
28.         For j = k To 1 Step -1 '在第n+1行，从第k列倒序计算抽取不重复随机数
    
29.             p = p + 1 '数组a中当前位置仍然+1
    
30.             r = Int(Rnd * m) + p '仍然从剩余数m中任选一个位置
    
31.             m = m - 1 '剩余数-1
    
32.             b(n + 1, j) = a(r) '第n+1行 写入本次抽取得到的不重复随机数a(r)
    
33.             a(r) = a(p)          '已被抽取掉数据的a(r)位置 交换写入未被抽取的当前p位置值a(p)
    
34.             If m = 0 Then Exit For  '当剩余数m=0时退出循环
    
35.         Next
    
36. &#160; &#160;&#160;End If
    
37. 
    
38.     [d1].CurrentRegion = "" '清空输出区域
    
39.     [d1].Resize(n + 1, k) = b '输出随机分组结果到D1单元格开始的区域
    
40. End Sub
    

复制代码

呵呵，这样的解释应该能看懂了吧。

香川群子

ghostjiao 发表于 2014-7-12 19:25
随机生成选择数据

If UBound(arr) Mod 8 = 0 Then n = UBound(arr) \ 8 Else n = UBound(arr) \ 8 + 1

这句代码可以简化计算为：

n = (UBound(arr) - 1) \ 8 + 1


即，计算m个元素分成k组时，每组最大n值是:
n = Int((m - 1) / k ) + 1

或在VBA中可简化为：
n = (m - 1) \ k + 1

呵呵。