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

yide1112

  求助：B列为员工姓名，共100人，其中男生58人，女生42人。需要从其中随机抽取男生30名，女生20名，将他们的姓名分别填写到D列和E列。求VBA代码，最好能注释一下，感谢！

yide1112

不重复抽取。求大神帮助。

yaozong

yide1112 发表于 2018-5-30 19:56
不重复抽取。求大神帮助。

Option Explicit
Public xx As Boolean

Private Sub CommandButton1_Click()
Dim a As Collection, j&, m&, n&
If CommandButton1.Caption = "抽取男生开始" Then
   CommandButton1.Caption = "抽取男生停止"
   xx = True
   Do While xx = True
      Set a = 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
      DoEvents
   Loop
Else
   CommandButton1.Caption = "抽取男生开始"
   xx = False
End If
End Sub

yaozong

Private Sub CommandButton2_Click()
Dim a As Collection, j&, m&, n&
If CommandButton2.Caption = "抽取女生开始" Then
   CommandButton2.Caption = "抽取女生停止"
   xx = True
   Do While xx = True
      Set a = New Collection
      For m = 2 To 101
        If Cells(m, 3) = "女" Then
         a.Add m
        End If
      Next m
      For j = 2 To 21
         n = Int(Rnd * a.Count) + 1
         Cells(j, 5) = Cells(a(n), 2)
         a.Remove (n)
      Next
      DoEvents
   Loop
Else
   CommandButton2.Caption = "抽取女生开始"
   xx = False
End If
End Sub

yaozong

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

2018-5-30 20:48 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   With Worksheets("sheet1")
   
5.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.     arr = .Range("a2:c" & r)
   
7.     ReDim brr(1 To UBound(arr))
   
8.     For i = 1 To UBound(arr)
   
9.       brr(i) = i
   
10.     Next
    
11.     sl = UBound(brr)
    
12.     For i = 1 To UBound(arr) - 1
    
13.       m = Int(Rnd() * (sl - i)) + i + 1
    
14.       temp = brr(i)
    
15.       brr(i) = brr(m)
    
16.       brr(m) = temp
    
17.     Next
    
18.     ReDim crr(1 To 30, 1 To 1)
    
19.     ReDim drr(1 To 20, 1 To 1)
    
20.     m = 0
    
21.     n = 0
    
22.     For i = 1 To UBound(brr)
    
23.       If arr(brr(i), 3) = "男" Then
    
24.         m = m + 1
    
25.         If m <= 30 Then
    
26.           crr(m, 1) = arr(brr(i), 2)
    
27.         End If
    
28.       Else
    
29.         n = n + 1
    
30.         If n <= 20 Then
    
31.           drr(n, 1) = arr(brr(i), 2)
    
32.         End If
    
33.       End If
    
34.     Next
    
35.     .Range("d2").Resize(UBound(crr), 1) = crr
    
36.     .Range("e2").Resize(UBound(drr), 1) = drr
    
37.   End With
    
38.    
    
39. End Sub
    

复制代码

半百

Sub TEST()
Dim BRR(1 To 100)
Set d = CreateObject("Scripting.Dictionary")
ARR = [A2:C101]
For I = 1 To 100
    BRR(I) = I
Next
Do While d.Count < 30
    N = Int(Rnd * 100) + 1
    If ARR(N, 3) = "男" Then
        d(N) = ARR(N, 2)
    End If
Loop
[D2:D31] = Application.Transpose(d.ITEMS)
d.RemoveAll
Do While d.Count < 20
    N = Int(Rnd * 100) + 1
    If ARR(N, 3) = "女" Then
        d(N) = ARR(N, 2)
    End If
Loop
[E2:E21] = Application.Transpose(d.ITEMS)
End Sub

chxw68

详见附件。

duquancai

yide1112 发表于 2018-5-30 19:56
不重复抽取。求大神帮助。

Sub main()
    Dim Data, rst$(), male$, female$, M&, F&, i&, a$(), b$(), x&, y&
    Data = [B2:C101] '初始化数据
    male = "男": female = "女"
    M = 30: F = 20 '初始化抽取"男女"数量
    For i = 1 To UBound(Data)
        If Data(i, 2) = male Then
            x = x + 1: ReDim Preserve a(1 To x)
            a(x) = Data(i, 1)
        Else
            y = y + 1: ReDim Preserve b(1 To y)
            b(y) = Data(i, 1)
        End If
    Next
    If M > x Or F > y Then Exit Sub '如果抽取数量大于样本数量，那么退出程序！
    ReDim rst(1 To IIf(M > F, M, F), 1 To 2)
    Call extract(a, rst, male, M, 1)
    Call extract(b, rst, female, F, 2)
    Range("D2").Resize(UBound(rst), 2) = rst
End Sub
Sub extract(p, q, ByVal MF, ByVal num&, ByVal x&)
    Dim n&, d As Object, k
    Set d = CreateObject("Scripting.Dictionary")
    Do While d.Count < num
        n = Int(Rnd * UBound(p)) + 1
        d(p(n)) = vbNullString
    Loop
    k = d.keys
    For n = 1 To num
        q(n, x) = k(n - 1)
    Next
End Sub

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, n, t
  arr = Range("b2:c" & Cells(Rows.Count, "b").End(xlUp).Row)
  Randomize
  For i = 1 To UBound(arr, 1)
    n = Int(Rnd * UBound(arr, 1)) + 1
    t = arr(i, 1): arr(i, 1) = arr(n, 1): arr(n, 1) = t
    t = arr(i, 2): arr(i, 2) = arr(n, 2): arr(n, 2) = t
  Next
  ReDim brr(1 To UBound(arr, 1), 1 To 2), n(1)
  For i = 1 To UBound(arr, 1)
    If arr(i, 2) = "男" Then
      If n(0) < 30 Then n(0) = n(0) + 1: brr(n(0), 1) = arr(i, 1)
    Else
      If n(1) < 20 Then n(1) = n(1) + 1: brr(n(1), 2) = arr(i, 1)
    End If
    If n(0) + n(1) = 50 Then Exit For
  Next
  [d2].Resize(UBound(brr, 1), 2) = brr
End Sub