|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub 随机班级不相连安排考场()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim r As Integer
Dim i%
Dim arr As Variant, brr As Variant
Dim d As Object, dc As Object, dic As Object, dd As Object
Dim br()
Dim rng As Range, rg As Range
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
Set dd = CreateObject("scripting.dictionary")
For Each sh In Sheets
If sh.Name <> "考生数据库" Then
sh.Delete
End If
Next sh
With Sheets("考生数据库")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "考生数据为空！": Exit Sub
brr = .[a1].CurrentRegion
Set rn = .Range("a1:g2")
sl = .[l1]
End With
For i = 3 To UBound(brr)
If Trim(brr(i, 6)) <> "" Then
d(Trim(brr(i, 6))) = ""
End If
Next i
For Each k In d.keys
n = 0: a = 0: mm = 0: m = 0
dc.RemoveAll: dic.RemoveAll: dd.RemoveAll
ReDim br(1 To UBound(brr), 1 To 7)
For i = 2 To UBound(brr)
If Trim(brr(i, 6)) = k Then
n = n + 1
For j = 1 To UBound(brr, 2)
br(n, j) = brr(i, j)
Next j
dic(br(n, 7)) = dic(br(n, 7)) + 1
End If
Next i
Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
With Sheets(Sheets.Count)
.Name = k
rn.Copy .[a1]
.[a1] = .[a1] & "（" & k & "年级）"
.[a3].Resize(n, UBound(br, 2)) = br
.[h2] = "随机数"
zd = n
Randomize
Do While mm < zd
x = Int(Rnd * zd + 1)
If Not dd.exists(x) Then
mm = mm + 1
.Cells(mm + 2, 8) = x
dd(x) = ""
End If
Loop
.Range("a2").Resize(n + 1, UBound(br, 2) + 1).Sort .[h2], 1, , , , , , 1 '按班级排序
.Range("a2").Resize(n + 1, UBound(br, 2) + 1).Sort .[g2], 1, , , , , , 1 '按班级排序
.[a2].Resize(n + 1, UBound(br, 2) + 1).Borders.LineStyle = 1
arr = .[a2].Resize(n + 1, UBound(br, 2))
nn = 0
gs = dic.Count
For i = 2 To UBound(arr)
If Not dc.exists(arr(i, 7)) Then
nn = nn + 1
arr(i, 4) = nn
dc(arr(i, 7)) = ""
Else
arr(i, 4) = arr(i - 1, 4) + gs
End If
Next i
For i = 2 To UBound(arr)
For s = i + 1 To UBound(arr)
If arr(i, 4) > arr(s, 4) Then
For j = 1 To UBound(arr, 2)
Kk = arr(i, j)
arr(i, j) = arr(s, j)
arr(s, j) = Kk
Next j
End If
Next s
Next i
For i = 2 To UBound(arr) Step sl
xh = 0
m = m + 1
For s = i To i + sl - 1
If s <= UBound(arr) Then
xh = xh + 1
arr(s, 4) = Format(arr(s, 6), "00") & Format(m, "00")
arr(s, 5) = xh
End If
Next s
Next i
.Columns("d:d").NumberFormatLocal = "@"
.Columns("a:g").AutoFit
.[a2].Resize(n + 1, UBound(br, 2)) = arr
.Columns("h:h").Delete
End With
Next k
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!" '
End Sub
|
|
楼主: 静坐123
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2021-11-22 16:15
楼主
