[已解决]不放回抽取

张雄友 · 发表于 2015-10-15 18:36

本帖最后由张雄友于 2015-10-20 18:31 编辑

不放回随机抽取参加市对抗赛，每人只能被抽取一次（即抽过的不能再抽），每次抽取的个数不定，如下格式。

Sub 随机抽取()
Dim rng As Range, 抽取个数, 剩下个数
Dim d As Object
Dim d1 As Object
Dim r&, i&
Dim arr, brr()
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
On Error Resume Next
抽取个数 = Val(InputBox("看看谁被抽到" & Chr(10) & "多少个？", "市名额", 17))
Randomize
With Worksheets("data")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("A7:B" & r)
End With
For i = 1 To r - 1
If Not d.Exists(arr(i, 1)) Then
Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
End If
d(arr(i, 1))(i) = ""
Next
m = 1
For Each aa In d.Keys
n = Application.Min(抽取个数, d(aa).Count) '随机抽取
For i = 1 To n
kk = d(aa).Keys
n = Int(Rnd() * d(aa).Count)
d1(kk(n)) = ""
d(aa).Remove kk(n)
Next
Next
ReDim brr(1 To d1.Count, 1 To 2)
kk = d1.Keys
For i = 0 To UBound(kk)
brr(i + 1, 1) = arr(kk(i), 1)
brr(i + 1, 2) = arr(kk(i), 2)
Next
Set rng = Application.InputBox("请选择输出单元格如 D7", "如下", , , , , , 8)
rng.Resize(抽取个数, 1).NumberFormatLocal = "@"
rng.Resize(抽取个数, 2) = brr
End Sub

复制代码

最佳答案

月排行榜 / 总排行榜

grf1973

2015-10-20 09:23

1、for j=4 to .....，循环取j=4,10,16。。。。每次都是取已提取数组的第4列（姓名）作为key进字典（因为源数组中也是拿第4列（工号唯一）作为key相比较的）
2、step 6 是因为每次提取都有5列，加上1列空格，是为6列
3、tqrr=.....是因为定义已提取数组要把已经提取的内容全部放进去，c是第一列的列号，而每次提取都有5列（其实只要保证姓名那列放进数组，c+3就可以了）

跳转到最佳答案楼层

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

做过类似的 http://club.excelhome.net/thread-1234748-1-1.html ，可参考。

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

Sub 提取()
arr = Range("a7:b" & [a65536].End(3).Row)
n = UBound(arr) '总组数
Set d = CreateObject("scripting.dictionary")
ytq = Application.WorksheetFunction.Sum(Rows(3)) '已提取量
n = n - ytq '剩下的总提取量
tql = Val(InputBox("看看谁被抽到" & Chr(10) & "多少个？", "市名额", 17)) '本次提取量
If tql > n Then tql = n '如果提取量大于剩余量，那么提取量=剩余量
ReDim brr(1 To tql, 1 To 2)
If ytq = 0 Then '未进行过提取
c = 1
Else '已进行过提取
c = Cells(3, 256).End(xlToLeft).Column
tqrr = Range([d7], Cells(UBound(arr) + 6, c + 1)) '已提取的组
For j = 1 To UBound(tqrr, 2) Step 3 '已提取过的内容进字典
For i = 1 To UBound(tqrr)
If tqrr(i, j) <> "" Then
d(tqrr(i, j)) = ""
End If
Next
Next
For i = 1 To UBound(arr) '剩下可提取的内容放到数组arr的前n位
If Not d.exists(arr(i, 1)) Then
kk = kk + 1
arr(kk, 1) = arr(i, 1): arr(kk, 2) = arr(i, 2)
End If
Next
End If
For i = 1 To tql '在arr中的前n位中提取tql个数
k = Int(Rnd * n) + 1 '生成1--n的随机数
brr(i, 1) = arr(k, 1): arr(k, 1) = arr(n, 1)
brr(i, 2) = arr(k, 2): arr(k, 2) = arr(n, 2)
n = n - 1
Next
Cells(3, c + 3) = tql
Cells(6, c + 3).Resize(1, 2) = Array("工号唯一", "体重公斤")
Cells(7, c + 3).Resize(tql, 2) = brr
End Sub

复制代码

grf1973 · 发表于 2015-10-16 10:57

改了简洁一点。

张雄友 · 发表于 2015-10-16 13:09

grf1973 发表于 2015-10-16 10:57
改了简洁一点。

第六句用相同变量n看不懂，不知下面的n是什么意思。？

grf1973 · 发表于 2015-10-16 16:54

自己逐句调试一下不就明白了？

grf1973 · 发表于 2015-10-16 16:55

n是可提取的总组数，每提掉一个，n=n-1

张雄友 · 发表于 2015-10-16 18:09

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

测试了一下午发现第16句；For j = 1 To UBound(tqrr, 2) Step 3 '已提取过的内容进字典

要将 Step 3 去掉才正确，如果不去掉有时会不正确。

张雄友 · 发表于 2015-10-16 18:37

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

用数字验证了一下，是错误的。假设用三次抽完，第一次抽17，第二次抽17，第三次抽600(第三次任)何大于总数的数保证抽完

张雄友 · 发表于 2015-10-17 18:36

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

If Not d.exists(arr(i, 1)) Then

是什么意思？如果不重复项目在第四列，是否If Not d.exists(arr(i, 4)) Then ？

还有什么要改的吗？数据测试了不正确。

		自动登录	找回密码
密码			注册

[已解决]不放回抽取

评分

评分