求一个从100名员工中，按性别随机抽取30名男生，20名女生的VBA代码

yaozong

男、女同时抽取时：

Option Explicit
Public xx As Boolean
Public yy As Boolean

Private Sub CommandButton1_Click()
Dim a As Collection, b As Collection, j&, m&, n&, jj&, mm&, nn&
If CommandButton1.Caption = "抽取开始" Then
   CommandButton1.Caption = "抽取停止"
   xx = True
   yy = True
   Do While xx = True Or yy = True
      Set a = New Collection
      Set b = New Collection
      For m = 2 To 101
        If Cells(m, 3) = "男" Then
         a.Add m
        End If
      Next m
      For j = 2 To 31
         n = Int(Rnd * a.Count) + 1
         Cells(j, 4) = Cells(a(n), 2)
         a.Remove (n)
      Next
      For mm = 2 To 101
        If Cells(mm, 3) = "女" Then
         b.Add mm
        End If
      Next mm
      For jj = 2 To 21
         nn = Int(Rnd * b.Count) + 1
         Cells(jj, 5) = Cells(b(nn), 2)
         b.Remove (nn)
      Next
      DoEvents
   Loop
Else
   CommandButton1.Caption = "抽取开始"
   xx = False
   yy = False
End If
End Sub

yaozong

参考附件             求助：按性别随机抽取指定数量的男女生2.rar (25.7 KB, 下载次数: 16)

2018-5-31 07:51 上传

点击文件名下载附件

yide1112

yaozong 发表于 2018-5-30 20:46
Option Explicit
Public xx As Boolean

麻烦，请注释下这一句：
n = Int(Rnd * a.Count) + 1

幸运的卫小西12

XIEXIE     

香川群子

我也凑热闹来一个。

我出手必是精品。

1. Sub test() 'by kagawa 2018/06/01
   
2.     ar = [a1].CurrentRegion '读取数据
   
3.     m = UBound(ar)          '最大行数m
   
4.     [d2].Resize(m, 2) = ""  '清空输出区域
   
5.     n1 = [d1]: n2 = [e1]    '提取男、女数量
   
6.     Randomize               '随机种子初始化保证每次结果随机
   
7.     For i = 2 To m          '数组随机乱序洗牌算法
   
8.         r = Int(Rnd * (m - i + 1)) + i  '不重复随机乱序位置r
   
9.         t = ar(r, 1): ar(r, 1) = ar(i, 1): ar(i, 1) = t '保证不重复的洗牌交换
   
10.         If ar(t, 3) = "男" Then
    
11.             If n1 Then Cells(n1 + 1, 4) = ar(t, 2): n1 = n1 - 1 '输出男生
    
12.         Else
    
13.             If n2 Then Cells(n2 + 1, 5) = ar(t, 2): n2 = n2 - 1 '输出女生
    
14.         End If
    
15.     Next
    
16.     MsgBox "OK"
    
17. End Sub
    

复制代码

香川群子

一把小刀闯天下 发表于 2018-5-31 06:53
Option Explicit

Sub test()

会看了一下大家的代码，你的这个代码，和我的思路是最接近的了。

但是细节有差异。我的比你简洁一点点吧。

一把小刀闯天下

香川群子 发表于 2018-6-1 13:46
会看了一下大家的代码，你的这个代码，和我的思路是最接近的了。

但是细节有差异。我的比你简洁一点点 ...

感谢群子老师的回复，确实简洁而且效率还高点。

我这代码苯了一点，先洗一遍再顺序抽牌，随机概率没有问题，效率差了一点（循环数：ubound(arr,1）+50)。老师这代码的循环数是ubound(arr,1)-1,觉得如果在循环中再加个条件循环数还可减少（最差情况还是ubound(arr,1)-1,但出现这种情况的可能性非常小，最好情况是50）。if n1+n2=0 then exit for

以后碰到类似的问题我用这方法：边洗边抽。哈哈哈

duquancai

香川群子 发表于 2018-6-1 13:41
我也凑热闹来一个。

我出手必是精品。

在 for循环中 加一句判断 If n1 + n2 = 0 Then Exit For

是否 影响 效率？

Zamyi

香川群子 发表于 2018-6-1 13:41
我也凑热闹来一个。

我出手必是精品。

脸厚不会红。
1、        ar(i, 1) = t纯属蛇足；
2、        当男或女一个取完后，也许在做无用功；
3、        逐个操作单元格就不用说了。
4、        简单也说不上。

Zamyi

1. Sub test()
   
2. Application.ScreenUpdating = False
   
3. Range("d2:e65536").ClearContents
   
4. Range("f2") = "=rand()"
   
5. n = [b65536].End(3).Row
   
6. Range("f2:f" & n).FillDown
   
7. Range("a2:f" & n).Sort [c2], 1, [f2], , 1
   
8. Range("b2").Resize(30).Copy [d2]
   
9. Range("b" & n - 20 & ":b" & n).Copy [e2]
   
10. Range("a2:c" & n).Sort [a2], 1
    
11. Range("f2:f" & n).ClearContents
    
12. Application.ScreenUpdating = True
    
13. End Sub

复制代码