[已解决]不放回抽取

lmze2000

张雄友 发表于 2015-10-19 07:43
不太明白，如改成这样？

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

复制代码

http://pan.baidu.com/s/1kTKWQiz  传不了超过1.1M的附件。

grf1973

张雄友 发表于 2015-10-16 18:37
用数字验证了一下，是错误的。假设用三次抽完，第一次抽17，第二次抽17，第三次抽600(第三次任)何大于总数 ...

不放回抽取.rar (30.12 KB, 下载次数: 3)

2015-10-19 10:10 上传

点击文件名下载附件
代码没错，试验了许多次总数都是52267。
可能是工作表里的格式有误，你用sum的时候文本内容没加进去。

grf1973

问题出在读入已提取工号时进字典时，文本型工号和数值型工号不同的。所以只要把输出工号的列格式设置成文本就没问题了。或者把源数据和已提取的工号全部转成数值型。

grf1973

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

Sub 不对的()

    On Error GoTo Err
    arr = Range("A7:E" & [A1048576].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) & "多少个？", "市名额", _
    Application.WorksheetFunction.RandBetween(1, Val(UBound(arr)))))

    If tql > n Then tql = n '如果提取量大于剩余量，那么提取量=剩余量

    ReDim brr(1 To tql, 1 To 5)
    If ytq = 0 Then '未进行过提取
        c = 1
    Else          '已进行过提取
        c = Cells(3, 256).End(xlToLeft).Column
        tqrr = Range([G7], Cells(UBound(arr) + 6, c + 5)) '已提取的组
        For j = 4 To UBound(tqrr, 2) Step 6 '已提取过的内容进字典
            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, 4)) Then '怎么不对？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？
                kk = kk + 1
                arr(kk, 1) = arr(i, 1)
                arr(kk, 2) = arr(i, 2)
                arr(kk, 3) = arr(i, 3)
                arr(kk, 4) = arr(i, 4)
                arr(kk, 5) = arr(i, 5)
            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)
        brr(i, 3) = arr(k, 3): arr(k, 3) = arr(n, 3)
        brr(i, 4) = arr(k, 4): arr(k, 4) = arr(n, 4)
        brr(i, 5) = arr(k, 5): arr(k, 5) = arr(n, 5)
        n = n - 1
    Next

    Cells(3, c + 6) = tql
    Cells(6, c + 6).Resize(1, 5) = Array("工号唯一", "体重公斤", "入厂日期", "姓名", "血液")
    Cells(7, c + 6).Resize(tql, 1).NumberFormatLocal = "@" '根据需要哪些列要强制文本！
    Cells(7, c + 6).Offset(0, 2).Resize(tql, 1).NumberFormatLocal = "yyyy-mm-dd"
    Cells(7, c + 6).Resize(tql, 5) = brr
    Cells(7, c + 6).Resize(tql, 5).EntireColumn.AutoFit
Err:
End Sub

grf1973

你原来这个代码的错误之处在于，你是用“姓名+工号”作为唯一key的，而原代码中进字典的是已提取内容的“工号”，两者不匹配，因此出错。再者tjrr的数组定义小了，第四列没定义进去。

grf1973

改过之后就对了。

张雄友

grf1973 发表于 2015-10-19 10:56
改过之后就对了。

c = Cells(3, 256).End(xlToLeft).Column
        tqrr = Range([G7], Cells(UBound(arr) + 6, c + 5)) '已提取的组
        For j = 4 To UBound(tqrr, 2) Step 6 '已提取过的内容进字典

红字的  5，与  4  不明白是什么意思，可否解释一下？？？Step 6  呢？

grf1973

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-20 09:23
1、for j=4 to .....，循环取j=4,10,16。。。。每次都是取已提取数组的第4列（姓名）作为key进字典（因为源 ...

再问多一下：If Not d.exists(arr(i, 4)) Then

是否说明以第四列为不重复依据时，该列不能有重复项目，否则会出错？？？

grf1973

有重复的也不会出错的，不过重复的内容如果提取过一次，其他所有重复内容不会被再提取。