excel按班级分组,每组按百分比随机抽取数据,两次抽取不重复
需求
有一张学生班级信息表,需要按每个班的人数比例,每次随机抽取6%的学生,且第二次抽取与第一次抽取的结果不能重复:
信息表如下图:
一、实现方案
使用VB编程,在开发工具,VB编辑器中插入一个模块,然后粘贴下面的代码并运行即可实现,按照A列分组并抽取6%的学生按C列区分存入sheet2
二、代码详情
Sub Getdates()
brr = Sheet2.Range("A1:D" & Sheet2.Cells(Rows.Count, "A").End(3).Row)
arr = Sheet1.Range("A1:C" & Sheet1.Cells(Rows.Count, "A").End(3).Row)
Dim t As Date
t = Now()
ReDim br(1 To UBound(arr), 1 To 4)
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
For I = 2 To UBound(brr)
d1(brr(I, 4)) = ""
Next
For I = 2 To UBound(arr)
d2(arr(I, 1)) = d2(arr(I, 1)) + 1
If Not d1.exists(arr(I, 3)) Then
d(arr(I, 1)) = d(arr(I, 1)) & "," & I
End If
Next
ar = d.items
cr = d.keys
d.RemoveAll
d1.RemoveAll
For I = 0 To UBound(ar)
arT = Split(Mid(ar(I), 2), ",")
' 6%后四舍五入
imax = Rand(d2(cr(I)) * 0.06)
If imax = o Then
imax = 1
End If
If UBound(arT) > 0 Then
Do While x < imax
num = WorksheetFunction.RandBetween(0, UBound(arT))
If Not d.exists(num) Then
d(num) = ""
x = x + 1
k = k + 1
br(k, 1) = t
br(k, 2) = arr(arT(num), 1)
br(k, 3) = arr(arT(num), 2)
br(k, 4) = arr(arT(num), 3)
End If
If d.Count = UBound(arT) + 1 Then
Exit Do
End If
Loop
d.RemoveAll
x = 0
imax = 0
Else
k = k + 1
br(k, 1) = t
br(k, 2) = arr(arT(0), 1)
br(k, 3) = arr(arT(0), 2)
br(k, 4) = arr(arT(0), 3)
End If
Next
If k > 0 Then
Sheet2.Range("A" & Sheet2.Cells(Rows.Count, "A").End(3).Row + 1).Resize(k, 4) = br
Erase br
End If
Erase arr
Erase brr
Set d2 = Nothing
Set d = Nothing
Set d1 = Nothing
End Sub
注意事项
VB编辑器,office任意版本均有;但WPS则需要专业版才有;或者是免费版但安装了VB编辑器插件