[已解决]不放回抽取

张雄友

grf1973 发表于 2015-10-16 16:55
n是可提取的总组数，每提掉一个，n=n-1

搞了二天，强烈不对啊。

1. Sub 不对的()
   
2. 
   
3. On Error GoTo Err
   
4. arr = Range("A7:E" & [A1048576].End(3).Row)
   
5. n = UBound(arr) '总组数
   
6. Set d = CreateObject("scripting.dictionary")
   
7. ytq = Application.WorksheetFunction.Sum(Rows(3)) '已提取量
   
8. n = n - ytq '剩下的总提取量
   
9. tql = Val(InputBox("看看谁被抽到" & Chr(10) & "多少个？", "市名额", _
   
10. Application.WorksheetFunction.RandBetween(1, Val(UBound(arr)))))
    
11. 
    
12. If tql > n Then tql = n '如果提取量大于剩余量，那么提取量=剩余量
    
13. 
    
14. ReDim brr(1 To tql, 1 To 5)
    
15. If ytq = 0 Then '未进行过提取
    
16. c = 1
    
17. Else '已进行过提取
    
18. c = Cells(3, 256).End(xlToLeft).Column
    
19. tqrr = Range([G7], Cells(UBound(arr) + 6, c + 1)) '已提取的组
    
20. For j = 1 To UBound(tqrr, 2) Step 6 '已提取过的内容进字典
    
21. For i = 1 To UBound(tqrr)
    
22. If tqrr(i, j) <> "" Then
    
23. d(tqrr(i, j)) = ""
    
24. End If
    
25. Next
    
26. Next
    
27. 
    
28. For i = 1 To UBound(arr) '剩下可提取的内容放到数组arr的前n位
    
29. If Not d.exists(arr(i, 4)) Then '怎么不对？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？
    
30. kk = kk + 1
    
31. arr(kk, 1) = arr(i, 1)
    
32. arr(kk, 2) = arr(i, 2)
    
33. arr(kk, 3) = arr(i, 3)
    
34. arr(kk, 4) = arr(i, 4)
    
35. arr(kk, 5) = arr(i, 5)
    
36. End If
    
37. Next
    
38. End If
    
39. 
    
40. For i = 1 To tql '在arr中的前n位中提取tql个数
    
41. k = Int(Rnd * n) + 1 '生成1--n的随机数
    
42. brr(i, 1) = arr(k, 1): arr(k, 1) = arr(n, 1)
    
43. brr(i, 2) = arr(k, 2): arr(k, 2) = arr(n, 2)
    
44. brr(i, 3) = arr(k, 3): arr(k, 3) = arr(n, 3)
    
45. brr(i, 4) = arr(k, 4): arr(k, 4) = arr(n, 4)
    
46. brr(i, 5) = arr(k, 5): arr(k, 5) = arr(n, 5)
    
47. n = n - 1
    
48. Next
    
49. 
    
50. Cells(3, c + 6) = tql
    
51. Cells(6, c + 6).Resize(1, 5) = Array("工号唯一", "体重公斤", "入厂日期", "姓名", "血液")
    
52. Cells(7, c + 6).Resize(tql, 1).NumberFormatLocal = "@" '根据需要哪些列要强制文本！
    
53. Cells(7, c + 6).Offset(0, 2).Resize(tql, 1).NumberFormatLocal = "yyyy-mm-dd"
    
54. Cells(7, c + 6).Resize(tql, 5) = brr
    
55. Cells(7, c + 6).Resize(tql, 5).EntireColumn.AutoFit
    
56. Err:
    
57. End Sub
    
58. 
    

复制代码

冬日夏雨

试试看。

张雄友

冬日夏雨 发表于 2015-10-18 07:09
试试看。

谢谢！很慢，假如，共60000个。数组输出应该很快才对。第一次抽取1个，第二次抽取59999个，半天 没反应。

冬日夏雨

再试试看，这回第二次抽取59999个，大约需要10秒左右。突然不能发附件了，试试这个链接地址中的文件h t t p : //pan.baidu.com/s/1ntCfoGL

冬日夏雨

为了方便传送，网盘文件里的数据，我减小到30000条，实际上可以增加到60000条进行测试。

张雄友

冬日夏雨 发表于 2015-10-18 14:06
再试试看，这回第二次抽取59999个，大约需要10秒左右。突然不能发附件了，试试这个链接地址中的文件h t t p ...

链接找不到东西，上代码即可。

金樽空对月

grf1973 发表于 2015-10-16 10:56

这代码写的，看的真是眼晕，先保存下来学习一下，水平有限呀，从来没写过这么长的篇的代码。

金樽空对月

张雄友 发表于 2015-10-17 18:46
搞了二天，强烈不对啊。

干嘛搞这么复杂，正名单放在一个表内，抽取几个完成后，就把这几个名字行剪切粘贴到另一个表内，再进行下一次抽取；全部抽取完成后，把剪切过去的名单恢复到原表中不就行了吗？

金樽空对月

张雄友 发表于 2015-10-18 08:36
谢谢！很慢，假如，共60000个。数组输出应该很快才对。第一次抽取1个，第二次抽取59999个，半天 没反应。 ...

EXCEL中的数组在元素超过50000个以后也不会很快的，

金樽空对月

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

这个速度的问题，前两天我帮别人处理过一次，刚开始他的代码是用单元格循环来的，我让它弄成数组，但他上传的数据只几千行，按成数组后就快了十倍，后来他说有九十多万行数据要统计，我也说用数组应该也没问题，结果同样的代码，就等不到结果了，简直就像死循环；后来测试了几次
50000万行以下，运行时间3秒多
50000到100000，运行时间6秒多
10万行以上到60万，运行时间5分多钟
60万行以上的就等半天没反应了。
这个帖应该还在浮着，你可以看一下。