|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub 生成座位表()
Dim ar As Variant
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("考场号和座位号安排")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "考场号和座位号安排为空！": End
ar = .Range("a1:d" & r)
End With
For i = 2 To UBound(ar)
If ar(i, 3) <> "" Then
zd = ar(i, 3) & "|" & Left(ar(i, 4), 2)
If Not d.exists(zd) Then Set d(zd) = CreateObject("scripting.dictionary")
d(zd)(i) = ""
End If
Next i
With Sheets("考试座位安排")
.UsedRange.Clear
For Each k In d.keys
n = 0
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For Each kk In d(k).keys
n = n + 1
br(n, 1) = Right(ar(kk, 4), 2) & Chr(10) & ar(kk, 2)
Next kk
m = 0
ReDim cr(1 To 9, 1 To 9)
cr(1, 1) = "前门"
cr(1, 2) = "讲台"
cr(9, 1) = "后门"
t = 5
For i = 1 To n Step 8
t = t - 1
sj = t Mod 2
m = 1
If sj = 0 Then
For s = i To i + 7
If s <= n Then
m = m + 1
cr(m, t) = br(s, 1)
End If
Next s
Else
For s = i + 7 To i Step -1
If s <= n Then
m = m + 1
cr(m, t) = br(s, 1)
End If
Next s
End If
Next i
cr(8, 1) = cr(9, 2)
cr(9, 2) = ""
rs = .UsedRange.Rows.Count + 2
If rs = 3 Then rs = 1
.Cells(rs, 1).Resize(1, 4).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = False
End With
Selection.Merge
.Cells(rs, 1) = k & "考场考试座位安排表"
.Cells(rs + 1, 2).Resize(1, 3).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.MergeCells = False
End With
Selection.Merge
.Cells(rs + 1, 1).Resize(9, 4) = cr
.Cells(rs + 1, 1).Resize(9, 4).Borders.LineStyle = 1
Next k
End With
MsgBox "ok!"
End Sub
|
|
楼主: cai2532
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2024-6-22 07:06
