|
|
Sub 随机抽取()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant, cr As Variant
Dim i As Long, r As Long, rs As Long
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
With Sheets("班级")
r = .Cells.Find("*", searchdirection:=xlPrevious).Row
y = .Cells(2, Columns.Count).End(xlToLeft).Column
ar = .Range(.Cells(2, 1), .Cells(r, y))
End With
With Sheets("条件")
yy = .Cells(2, Columns.Count).End(xlToLeft).Column
br = .Range(.Cells(2, 1), .Cells(3, yy))
End With
For j = 2 To UBound(br, 2)
If br(2, j) <> "" Then
If IsNumeric(br(2, j)) Then
d(br(1, j)) = br(2, j)
End If
End If
Next j
With Sheets("抽取")
ms = .Cells(2, Columns.Count).End(xlToLeft).Column
.UsedRange.Offset(2) = Empty
cr = .Range(.Cells(2, 1), .Cells(r, ms))
For j = 1 To UBound(cr, 2)
If cr(1, j) <> "" Then
dc(cr(1, j)) = j
End If
Next j
For j = 1 To UBound(ar, 2)
dic.RemoveAll
sl = d(ar(1, j))
lh = dc(ar(1, j))
n = 1
ws = Sheets("班级").Cells(Rows.Count, j).End(xlUp).Row - 1
Do
xh = Application.RandBetween(2, ws)
xm = ar(xh, j)
If Not dic.exists(xm) Then
n = n + 1
If n > sl + 1 Then GoTo 10
cr(n, lh) = xm
dic(xm) = ""
End If
Loop
10:
Next j
.Range(.Cells(2, 1), .Cells(r, ms)) = cr
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-9-14 08:35
楼主