每班随机抽取不重复同学参加活动

songshihai · 发表于 2024-9-14 12:31

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

Qs18 · 发表于 2024-9-14 12:33

Sub qs()
Dim arr, i, j, x, dic, temp
Set dic = CreateObject("scripting.dictionary")
drr = Sheets("条件").Range("b3:q3").Value
With Sheet1
For col = 1 To UBound(drr, 2)
If drr(1, col) <> Empty Then
rw = .Cells(Rows.Count, col).End(3).Row
brr = .Range(Cells(3, col), Cells(rw, col)).Value
x = UBound(brr)
ReDim arr(1 To x)
For i = 1 To x ' 初始化数组
arr(i) = i
Next i
For i = 1 To x ' 随机排列数组
j = i + Int((x - i + 1) * Rnd)
temp = arr(i) ' 交换元素
arr(i) = arr(j)
arr(j) = temp
Next i
dic.RemoveAll
For i = 1 To UBound(arr)
dic(arr(i)) = brr(i, 1)
Next
ReDim Err(1 To drr(1, col), 1 To 1)
For w = 1 To drr(1, col)
Err(w, 1) = dic(w)
Next
With Sheets("抽取")
.Cells(3, col).Resize(10000, 1) = ""
.Cells(3, col).Resize(drr(1, col), 1) = Err
End With
End If
Next
End With
Sheets("抽取").Select
End Sub

复制代码

Qs18 · 发表于 2024-9-14 12:34

试试。。。。。。。。

Qs18 · 发表于 2024-9-14 12:35

试试。。。。。。

ky701 · 发表于 2024-9-14 14:02

Qs18 发表于 2024-9-14 12:35
试试。。。。。。

非常感谢！！

ky701 · 发表于 2024-9-14 14:06

songshihai 发表于 2024-9-14 12:31
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

非常感谢！复制不下来

一招秒杀 · 发表于 2024-9-14 16:15

专业的工具干专业的事情，SQL 1句3行全部搞定，
如果不考虑非要这种格式，2行就够了，
语言领先一代，效率胜人一筹。
再看你们那好几行的代码，真让人头大，好想撞墙啊。

songshihai · 发表于 2024-9-14 16:24

ky701 发表于 2024-9-14 14:06
非常感谢！复制不下来

照抄一下,我不会发文件

sunya_0529 · 发表于 2024-9-16 08:09

WPS里的JSA练习一下——

ZHLK · 发表于 2024-9-16 10:25

Sub aa()

Sheet2.Range("A3:P100").ClearContents
For i = 1 To 16
Sheet4.Cells.ClearContents
a = 1
For j = 3 To Sheet1.Cells(65320, i).End(3).Row
      If Sheet1.Cells(a + 2, i) <> "" Then
         Sheet4.Cells(a, 1) = Sheet1.Cells(j, i)
         a = a + 1
      End If
Next j
b = 2
For k = 1 To Sheet3.Cells(3, i + 1)
      l = Application.WorksheetFunction.RandBetween(1, Sheet4.Cells(65320, i).End(3).Row)
      Sheet2.Cells(b + 1, i) = Sheet4.Cells(l, 1)
      Sheet4.Rows(l).Delete
      b = b + 1
Next k
Next i

End Sub

		自动登录	找回密码
密码			免费注册

[求助] 每班随机抽取不重复同学参加活动