|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub 安排考场()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant, rr As Variant
Dim d As Object, dc As Object, dic As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
Dim br(), cr()
Dim rn As Range
For Each sh In Sheets
If sh.Index > 3 Then
sh.Delete
End If
Next sh
With Sheets("考场设置")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
If rs < 3 Then MsgBox "请先设置考场号和考场人数！": Exit Sub
rr = .Range("a2:b" & rs)
End With
With Sheets("考生名单")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "考生名单为空，请先导入数据！": End
.Range("a1:d" & r).Sort Key1:=.[d1], Order1:=xlDescending, Header:=xlYes
ar = .Range("a1:f" & r)
End With
ReDim br(1 To UBound(ar), 1 To 5)
n = 1
For j = 1 To 3
br(n, j) = ar(1, j)
Next j
br(n, 4) = "考场号"
br(n, 5) = "座位号"
For i = 2 To UBound(ar)
If ar(i, 2) <> "" Then
n = n + 1
For j = 1 To 3
br(n, j) = ar(i, j)
Next j
If Not d.exists(br(n, 2)) Then
nn = nn + 1
d(br(n, 2)) = nn
End If
End If
Next i
For i = 2 To n
br(i, 5) = d(br(i, 2))
d(br(i, 2)) = d(br(i, 2)) + d.Count
Next
For i = 2 To n
For s = i + 1 To n
If br(i, 5) > br(s, 5) Then
For j = 1 To UBound(br, 2)
kk = br(i, j)
br(i, j) = br(s, j)
br(s, j) = kk
Next j
End If
Next s
Next i
a = 1
For i = 2 To UBound(rr)
If rr(i, 1) <> "" And rr(i, 2) <> "" Then
For s = 1 To rr(i, 2)
a = a + 1
br(a, 4) = rr(i, 1)
br(a, 5) = Format(s, "00")
If Not dc.exists(br(a, 2)) Then Set dc(br(a, 2)) = CreateObject("scripting.dictionary")
dc(br(a, 2))(a) = a
If Not dic.exists(br(a, 4)) Then Set dic(br(a, 4)) = CreateObject("scripting.dictionary")
dic(br(a, 4))(a) = a
Next s
End If
Next i
With Sheets("考场安排")
.[a1].CurrentRegion = Empty
.Columns("E:E").NumberFormatLocal = "@"
.[a1].Resize(n, UBound(br, 2)) = br
Set rn = .Rows(1)
End With
For Each k In dc.keys
m = 0
ReDim cr(1 To n, 1 To 5)
For Each kk In dc(k).keys
m = m + 1
For j = 1 To UBound(br, 2)
cr(m, j) = br(kk, j)
Next j
Next kk
Set sht = Worksheets.Add(after:=Sheets(Sheets.Count))
With sht
.Name = k
.Range("A1:E1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = False
End With
Selection.Merge
.[a1] = k & "班级考场安排情况表"
rn.Copy .[a2]
.Columns("E:E").NumberFormatLocal = "@"
.[a3].Resize(m, UBound(cr, 2)) = cr
With .[a3].Resize(m, UBound(cr, 2))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
.[a2].Resize(m + 1, UBound(cr, 2)).Borders.LineStyle = 1
.Columns("a:e").AutoFit
End With
Next k
For Each k In dic.keys
m = 0
ReDim cr(1 To n, 1 To 5)
For Each kk In dic(k).keys
m = m + 1
For j = 1 To UBound(br, 2)
cr(m, j) = br(kk, j)
Next j
Next kk
Set sht = Worksheets.Add(after:=Sheets(Sheets.Count))
With sht
.Name = k
.Range("A1:E1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = False
End With
Selection.Merge
.[a1] = k & "安排情况表"
rn.Copy .[a2]
.Columns("E:E").NumberFormatLocal = "@"
.[a3].Resize(m, UBound(cr, 2)) = cr
With .[a3].Resize(m, UBound(cr, 2))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
.[a2].Resize(m + 1, UBound(cr, 2)).Borders.LineStyle = 1
.Columns("a:e").AutoFit
End With
Next k
Sheets("考场设置").Select
Set d = Nothing
Set dc = Nothing
Set dic = Nothing
Set rn = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-5-22 15:15
楼主
