|
|
楼主 |
发表于 2020-7-23 11:24
|
显示全部楼层
Sub 导出登分单()
Application.ScreenUpdating = False
Dim d As Object, dc As Object
Dim br()
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("设置")
y = .Cells(6, Columns.Count).End(xlToLeft).Column
rs = .Cells(Rows.Count, 1).End(xlUp).Row
If y < 2 Then MsgBox "请先导入考生数据！": Exit Sub
If rs < 9 Then MsgBox "请先安排考场！": Exit Sub
ar = .Range(.Cells(8, 1), .Cells(rs, y))
mc = .[b1] & .[b2] & .[c2] & .[d2] & .[b3] & .[b4]
End With
Application.SheetsInNewWorkbook = 1
rr = Array("考号", "成绩", "考号", "成绩", "考号", "成绩", "考号", "成绩")
For j = 3 To UBound(ar, 2)
If Trim(ar(1, j)) <> "" Then
m = 1
Set wb = Workbooks.Add
tt = 1
For i = 2 To UBound(ar)
If Trim(ar(i, 1)) <> "" And Trim(ar(i, j)) <> "" Then
y = 1
With wb.Worksheets(1)
.Name = ar(1, j)
.Range("a" & m & ":h" & m).Merge
.Rows(m).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.RowHeight = 20.25
End With
With Selection.Font
.Name = "宋体"
.Size = 16
End With
.Range("a" & m) = mc & "成绩登分册"
.Cells(m + 1, 1) = "年级："
.Cells(m + 1, 4) = "科目："
.Cells(m + 1, 7) = "考场："
.Cells(m + 1, 8) = "第" & ar(i, 1) & "考场"
.Cells(m + 2, 1).Resize(1, 8) = rr
Selection.Font.Bold = True
For s = 1 To ar(i, j) Step 10
K = m + 2
For w = s To s + 9
If w > ar(i, j) Then GoTo 10
K = K + 1
.Cells(K, y) = w
10:
Next w
y = y + 2
Next s
.Range(.Cells(m + 2, 1), .Cells(m + 12, 8)).Borders.LineStyle = 1
End With
m = m + 14
End If
Next i
wb.SaveAs Filename:=ThisWorkbook.Path & "\考场安排数据\" & mc & ar(1, j) & "成绩登分单"
wb.Close
End If
Next j
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
楼主: 3190496160
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2020-8-9 01:35
