[已解决]不放回抽取

张雄友

金樽空对月 发表于 2015-10-18 15:28
这个速度的问题，前两天我帮别人处理过一次，刚开始他的代码是用单元格循环来的，我让它弄成数组，但他上 ...

如：
If gs = "" Then
Exit Sub
End If

我觉得下面的方法比上面的要提速：

If gs = "" Then Exit Sub

三句用一句来表达。

金樽空对月

张雄友 发表于 2015-10-18 17:47
如：
If gs = "" Then
Exit Sub

嗯，感谢分享。

冬日夏雨

1. Public arr(), drr(), cs, sx
   
2. Sub 抽奖()
   
3. cs = cs + 1
   
4. If cs > 1 Then
   
5. GoTo zd
   
6. End If
   
7. r = Application.CountA(Sheet1.Range("a1:a1048576")) - 1
   
8. drr = Sheet1.Range("a1:e" & r + 1)
   
9. ReDim arr(1 To r)
   
10. For k = 1 To r
    
11. arr(k) = k + 1
    
12. Next
    
13. sx = r
    
14. zd:
    
15. 
    
16. tz:
    
17. gs = InputBox("请输入抽取个数：" & "还剩" & sx & "个")
    
18. If gs = "" Then
    
19. Exit Sub
    
20. End If
    
21. If Val(gs) > sx Then
    
22. MsgBox "抽取个数大于剩余个数，请调整抽取个数!"
    
23. GoTo tz
    
24. End If
    
25. ReDim brr(1 To gs)
    
26. For n = 1 To gs
    
27. x = Int(Rnd() * (sx - n + 1)) + 1
    
28. brr(n) = arr(x)
    
29. arr(x) = arr(sx - n + 1)
    
30. Next
    
31. ReDim crr(1 To gs, 1 To 5)
    
32. For m = 1 To gs
    
33. crr(m, 1) = drr(brr(m), 1)
    
34. crr(m, 2) = drr(brr(m), 2)
    
35. crr(m, 3) = drr(brr(m), 3)
    
36. crr(m, 4) = drr(brr(m), 4)
    
37. crr(m, 5) = drr(brr(m), 5)
    
38. Next
    
39. wz = InputBox("请选择输出单元格如 F2")
    
40. Sheet1.Range(wz).Resize(gs, 1).NumberFormatLocal = "@"
    
41. Sheet1.Range(wz).Offset(0, 2).Resize(gs, 1).NumberFormatLocal = "yyyy-mm-dd"
    
42. Sheet1.Range(wz).Resize(gs, 5) = crr
    
43. sx = sx - gs
    
44. End Sub
    
45. 
    
46. Sub 清零()
    
47. sx = 0
    
48. cs = 0
    
49. Erase arr()
    
50. End Sub
    

复制代码

冬日夏雨

张雄友 发表于 2015-10-18 14:50
链接找不到东西，上代码即可。

我也是初学者，我的体会是对于工作表而言，尽量少进行读写操作，必要时整体赋值，数据的运算尽量在内存中进行，还有就是循环不能嵌套太多层。

张雄友

循环不能嵌套太多层，这是提速的根本办法。

lmze2000

也写了一个，请参考一下。

1. Sub Ax()
   
2.     Dim Arr, Brr, Dic, D1, Cq, Wz As Range, Col, Crr
   
3.     Arr = Range("a7:b" & Cells(Rows.Count, 1).End(3).Row)
   
4.     Cq = Application.InputBox("请指定抽取人数", "设置", 20, , , , , 1)
   
5.     Set Wz = Application.InputBox("请指定保存位置", "设置", , , , , , 8)
   
6.     Set Dic = CreateObject("Scripting.Dictionary")
   
7.     Set D1 = CreateObject("Scripting.Dictionary")
   
8.     ReDim Crr(1 To Cq, 1 To 2)
   
9.     Col = Columns.Count - 1
   
10.     t = Timer
    
11.     ''将原始数据，装进字典
    
12.     For i = 1 To UBound(Arr)
    
13.         Dic(Arr(i, 1)) = Arr(i, 2)
    
14.     Next
    
15.     If Cells(2, Col) <> "" Then
    
16.         Brr = Cells(2, Col).CurrentRegion
    
17.         For i = 1 To UBound(Brr)
    
18.             Dic.Remove (Brr(i, 1))  '去除已经抽取过的数据
    
19.         Next
    
20.     End If
    
21.     If Dic.Count = 0 Then           '如果全抽空，清空缓冲区
    
22.         If MsgBox("数据已经抽空，请重新开始", vbYesNo, "提示") Then
    
23.             Cells(2, Col).CurrentRegion.ClearContents
    
24.         End If
    
25.     End If
    
26.     On Error Resume Next
    
27.     Randomize
    
28.     If Dic.Count > Cq Then      '单组抽取数量小于可抽取数量时，随机抽取
    
29.         Do While js < Cq
    
30.             n = Int(Rnd() * (Dic.Count - 1)) + 1
    
31.             If Not D1.exists(Dic.keys()(n)) Then
    
32.                 js = js + 1
    
33.                 D1(Dic.keys()(n)) = Dic.items()(n)
    
34.             End If
    
35.         Loop
    
36.         For i = 0 To D1.Count - 1
    
37.             Crr(i + 1, 1) = D1.keys()(i)
    
38.             Crr(i + 1, 2) = D1.items()(i)
    
39.         Next
    
40.     Else
    
41.         For i = 0 To Dic.Count - 1          '单组抽取数量大于可用抽取数量时，
    
42.             Crr(i + 1, 1) = Dic.keys()(i)
    
43.             Crr(i + 1, 2) = Dic.items()(i)
    
44.         Next
    
45.     End If
    
46.     Wz.Resize(UBound(Crr), 2) = Crr
    
47.     Cells(1, Col).Resize(UBound(Crr), 2).Offset(Cells(Rows.Count, Col).End(3).Row) = Crr
    
48.     MsgBox Format(Timer - t, "0.00") & "秒"
    
49. End Sub

复制代码

不放回抽取.zip (33.45 KB, 下载次数: 5)

2015-10-18 21:02 上传

点击文件名下载附件

张雄友

lmze2000 发表于 2015-10-18 21:02
也写了一个，请参考一下。

    Crr(i + 1, 1) = D1.keys()(i)
            Crr(i + 1, 2) = D1.items()(i)

根据我对字典的了解，上代码只适合二列的数据（一个key，一个item）抽取，像11楼多列数据如5列，好像不能实现对吗？请不要怪我无知。

lmze2000

张雄友 发表于 2015-10-18 22:17
Crr(i + 1, 1) = D1.keys()(i)
            Crr(i + 1, 2) = D1.items()(i)

只是针对你发的那个问题，11楼的，没有看见是什么样子的结构，如果保证只有一个关键字，后面的都是附属字段，都没有问题，不过即便有2个或者多个关键字，道理也应该是相通的。

lmze2000

张雄友 发表于 2015-10-18 22:17
Crr(i + 1, 1) = D1.keys()(i)
            Crr(i + 1, 2) = D1.items()(i)

下载看了你的11楼附件了，和正常的没有什么不同啊，字典是有二个属性keys/items，items可以是单个也可以是多个字段的组合呀。

比如：

编号	体重公斤	入厂日期	工号唯一	血液
00001	31	2015-10-17	AC1	G
00002	29	2015-10-18	AC2	K
00003	39	2015-10-19	AC3	J
00004	71	2015-10-20	AC4	E
00005	94	2015-10-21	AC5	J

这是你的数据，，，如果你想用工号唯一这个做key,那么其它的4项就可以作为item

1. Sub Ax()
   
2.     Dim Arr, Dic
   
3.     Set Dic = CreateObject("Scripting.Dictionary")
   
4.     Arr = [a6].CurrentRegion
   
5.     For i = 1 To UBound(Arr)
   
6.         bz = Arr(i, 1) & "*" & Arr(i, 2) & "*" & Arr(i, 3) & "*" & Arr(i, 5)
   
7.         Dic(Arr(i, 4)) = bz
   
8.     Next
   
9. End Sub

复制代码

之后的实际情况就是key AC1对应的item就是 "00001*31*2015-10-17*G"
在使用的时候，split就OK了。

张雄友

lmze2000 发表于 2015-10-19 07:29
下载看了你的11楼附件了，和正常的没有什么不同啊，字典是有二个属性keys/items，items可以是单个也可以是 ...

不太明白，如改成这样？