考场安排系统

3190496160

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
   

boyljd

你能把附件都弄完整在发吗？ 只能排考场其他都不行。排考场还不能自定义考号(考生都有固定考号的，不用你自动生成)

3190496160

boyljd 发表于 2020-8-9 01:35
你能把附件都弄完整在发吗？ 只能排考场其他都不行。排考场还不能自定义考号(考生都有固定考号的，不用你自 ...

你自己不会动脑子，没有测试号的东西，不会发上来的，你自己没认真测试，请注意你说话的语气，
考生都有固定考号的，不用你自动生成   太狭隘了吧，以偏概全

liuxi001

我也写了个小学的，蹭下楼主的贴。
http://club.excelhome.net/thread-1455269-1-1.html

boyljd

boyljd 发表于 2020-8-9 01:35
你能把附件都弄完整在发吗？ 只能排考场其他都不行。排考场还不能自定义考号(考生都有固定考号的，不用你自 ...

难怪没人支持你，就我一个人回复你，你还这么激动。
你丢一堆代码在那里有几个会去添加了看的，会添加代码的也会自己弄，不需要你这种

zpy2

boyljd 发表于 2020-8-11 01:31
难怪没人支持你，就我一个人回复你，你还这么激动。
你丢一堆代码在那里有几个会去添加了看的，会添加代 ...

我来罗嗦二句
第一，有人支持和没人支持不是选举，差别不大。
第二，人多支持，说明受欢迎，的确不错。
第三，还要受到时间考验，而且能够分享比拿到代码直接删帖好
袁芳你这么看？

3190496160

修正了一个小错误，需要请下载这个附件

考场安排系统.rar (331.74 KB, 下载次数: 779)

2020-11-3 08:48 上传

点击文件名下载附件

不鸣则已

很好谢谢，正好需要

不鸣则已

能不能设置考号和座号按我自己设置的安排，现在是按序号自动排列

不鸣则已

门贴好像没有自动生成的按钮