考场安排系统

3190496160

主要功能：

1、自动导入考生名单数据

2、可以单独安排某一个年级，也可以做年级交叉考试安排

3、自由设定各个考场的考生数

4、输入考场数自动生成考场号

5、输入每个年级每个考场的考生数，动态显示该年级总人数，已经安排人数和差异数

6、目前代码，按考生班级不相连安排考场

7、多个考场安排表格一键导出：班级安排表，考场安排表，桌贴，转考证，登分表，登分单，

8、选择年级批量打印考场门贴，

9、自动一键导出带照片的准考证，

操作提示：

1、按考生数据库中的列字段，整理好所有年级所有班级的考生数据，字段包括：年级，班级，姓名，上次考试成绩

2、点击按钮导入考生数据，点击按钮出现选择文件对话框，选择相应的文件导入，同时在设置工作表内自动生成各个年级的考生总数和桌贴中的下拉菜单

3、各种考场安排所需表格都可以一键导入，文件导入到同一个路径下的“考场安排数据”文件夹内。

3190496160

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

2020-7-23 11:07 上传

点击文件名下载附件

3190496160

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

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

2020-11-3 08:48 上传

点击文件名下载附件

3190496160

目前的系统还没有经过实际应用测试，可能还会存在一定的瑕疵，请提出你的宝贵意见，拒绝嘲讽

3190496160

Sub 导入考生数据()
Application.ScreenUpdating = False
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Dim arr As Variant, brr As Variant
Dim i As Long
p = MsgBox("导入数据的模板列字段必须保证有考生数据库的所有列字段，如果需要按上次考试成绩安排考场，还必须要有考生成绩，是否继续？", vbYesNo)
If p = vbNo Then Exit Sub
With Sheets("考生数据库")
    .[a1].CurrentRegion.Offset(1) = Empty
    arr = .Range("a1:e50000")
    For j = 2 To UBound(arr, 2)
        If Trim(arr(1, j)) <> "" Then
            d(Trim(arr(1, j))) = j
        End If
    Next j
    fileOpenName = Application.GetOpenFilename("Excel文件(*.xls*),*.xls")
    If fileOpenName = False Then Exit Sub
    Set wb = Workbooks.Open(fileOpenName)
    brr = wb.Worksheets(1).[a1].CurrentRegion
    n = 1
    For i = 2 To UBound(brr)
        If Trim(brr(i, 1)) <> "" Then
            n = n + 1
            arr(n, 1) = n - 1
            For j = 1 To UBound(brr, 2)
                m = d(Trim(brr(1, j)))
                If m <> "" Then
                    arr(n, m) = brr(i, j)
                End If
            Next j
            dc(Trim(arr(i, 2))) = dc(Trim(arr(i, 2))) + 1
        End If
    Next i
    If n = 1 Then MsgBox "导入表为空！": Exit Sub
    .[a1].Resize(n, UBound(arr, 2)) = arr
End With
wb.Close False
Sheets("门贴").Select
Sheets("门贴").Range("S1").Select
With Selection.Validation
     .Delete
     .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
     xlBetween, Formula1:=Join(dc.keys, ",")
    Application.WindowState = xlMinimized
End With
With Sheets("设置")
    y = .Cells(8, Columns.Count).End(xlToLeft).Column + 5
    .Range(.Cells(8, 3), .Cells(8, y)) = Empty
    .[c8].Resize(1, dc.Count) = dc.keys
    .[h2].CurrentRegion.Offset(1) = Empty
    .[h2].Resize(dc.Count, 2) = Application.Transpose(Array(dc.keys, dc.items))
    .Select
End With
Application.ScreenUpdating = True
MsgBox "导入成功!"
End Sub

3190496160

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
Dim br()
Dim rng As Range
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("设置")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    If rs < 9 Then MsgBox "请先设置考场号和考场人数！": Exit Sub
    y = .Cells(8, Columns.Count).End(xlToLeft).Column
    rr = .Range(.Cells(8, 1), .Cells(rs, y))
End With
For Each sh In Sheets
    If sh.Name <> "设置" And sh.Name <> "考生数据库" And sh.Name <> "桌贴模板" And sh.Name <> "准考证模板" And 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
End With
For i = 2 To UBound(brr)
    If Trim(brr(i, 2)) <> "" Then
        d(Trim(brr(i, 2))) = ""
     End If
Next i
For Each K In d.keys
    n = 0: a = 0
    dc.RemoveAll
    ReDim br(1 To UBound(brr), 1 To 7)
    For i = 2 To UBound(brr)
        If Trim(brr(i, 2)) = K Then
            n = n + 1
            For j = 2 To 4
                br(n, j - 1) = brr(i, j)
            Next j
        End If
    Next i
    Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
    With Sheets(Sheets.Count)
        .Name = K
        .[a1].Resize(1, 7) = Array("年级", "班级", "姓名", "考场位置", "考号", "考场号", "座位号")
        .[a2].Resize(n, UBound(br, 2)) = br
         .Range("a1").Resize(n, UBound(br, 2)).Sort .[a1], 1, , , , , , 1 '按班级排序
        .[a2].Resize(n, UBound(br, 2)).Borders.LineStyle = 1
        arr = .[a2].Resize(n, UBound(br, 2))
        nn = 0
        For i = 1 To UBound(arr)
            If Not dc.exists(arr(i, 2)) Then
                nn = nn + 1
                dc(arr(i, 2)) = nn
            End If
        Next i
        For i = 1 To UBound(arr)
            arr(i, 5) = d(arr(i, 2))
            d(arr(i, 2)) = d(arr(i, 2)) + d.Count
        Next
        For i = 1 To UBound(arr)
            For s = i + 1 To UBound(arr)
                If arr(i, 5) > arr(s, 5) 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
        Set rng = Sheets("设置").Rows(8).Find(K, , , 1)
        If rng Is Nothing Then MsgBox "设置中没有" & K & "年级的信息": Exit Sub
        ws = rng.Column
        For s = 2 To UBound(rr)
            If Trim(rr(s, ws)) <> "" Then
                For y = 1 To rr(s, ws)
                    a = a + 1
                    arr(a, 4) = rr(s, 2)
                    arr(a, 6) = Format(rr(s, 1), "000")
                    arr(a, 7) = Format(y, "00")
                    arr(a, 5) = Format(rr(s, 1), "00") & Format(y, "00")
                Next y
            End If
        Next s
        .Columns("E:G").NumberFormatLocal = "@"
        .[a2].Resize(n, UBound(br, 2)) = arr
    End With
Next K
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"'
End Sub

3190496160

Sub 生成班级安排表()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim d As Object
Dim rng As Range
Set d = CreateObject("scripting.dictionary")
With ThisWorkbook.Worksheets("设置")
    mc = .[b1] & .[b2] & .[c2] & .[d2] & .[b3] & .[b4]
End With
For Each sh In ThisWorkbook.Worksheets
    If sh.Name <> "设置" And sh.Name <> "考生数据库" And sh.Name <> "桌贴模板" And sh.Name <> "准考证模板" And sh.Name <> "门贴" Then
        d.RemoveAll
        ar = sh.[a1].CurrentRegion
        Set rng = sh.Rows(1)
        For i = 2 To UBound(ar)
            If Trim(ar(i, 2)) <> "" Then
                If Not d.exists(Trim(ar(i, 2))) Then
                    Set d(Trim(ar(i, 2))) = sh.Range("a" & i).Resize(1, UBound(ar, 2))
                Else
                    Set d(Trim(ar(i, 2))) = Union(d(Trim(ar(i, 2))), sh.Range("a" & i).Resize(1, UBound(ar, 2)))
                End If
            End If
        Next i
        x = d.keys
        Application.SheetsInNewWorkbook = 1
        Set wb = Workbooks.Add
        For i = 0 To UBound(x)
            Set sht = Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
            With sht
                .Name = x(i) & "班"
                .Range("a1:g1").Merge
                .Range("a1:g1").Select
                With Selection
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                End With
                .[a1] = mc & sh.Name & x(i) & "班安排表"
                rng.Copy .[a2]
                d.items()(i).Copy .[a3]
                rs = .Cells(Rows.Count, 1).End(xlUp).Row - 1
                .[a2].Resize(rs, 7).Borders.LineStyle = 1
            End With
        Next i
        wb.Worksheets(1).Delete
        wb.SaveAs Filename:=ThisWorkbook.Path & "\考场安排数据\" & mc & sh.Name & "班级安排表"
        wb.Close
    End If
Next sh
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

Sub 生成考场安排表()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim d As Object
Dim rng As Range
Set d = CreateObject("scripting.dictionary")
With ThisWorkbook.Worksheets("设置")
    mc = .[b1] & .[b2] & .[c2] & .[d2] & .[b3] & .[b4]
End With
For Each sh In ThisWorkbook.Worksheets
    If sh.Name <> "设置" And sh.Name <> "考生数据库" And sh.Name <> "桌贴模板" And sh.Name <> "准考证模板" And sh.Name <> "门贴" Then
        d.RemoveAll
        ar = sh.[a1].CurrentRegion
        Set rng = sh.Rows(1)
        For i = 2 To UBound(ar)
            If Trim(ar(i, 6)) <> "" Then
                If Not d.exists(Trim(ar(i, 6))) Then
                    Set d(Trim(ar(i, 6))) = sh.Range("a" & i).Resize(1, UBound(ar, 2))
                Else
                    Set d(Trim(ar(i, 6))) = Union(d(Trim(ar(i, 6))), sh.Range("a" & i).Resize(1, UBound(ar, 2)))
                End If
            End If
        Next i
        x = d.keys
        Application.SheetsInNewWorkbook = 1
        Set wb = Workbooks.Add
        For i = 0 To UBound(x)
            Set sht = Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
            With sht
                .Name = Format(x(i), "000") & "考场"
                .Range("a1:g1").Merge
                .Range("a1:g1").Select
                With Selection
                    .HorizontalAlignment = xlCenter
                     .VerticalAlignment = xlCenter
                 End With
                 .[a1] = mc & sh.Name & x(i) & "考场安排表"
                rng.Copy .[a2]
                d.items()(i).Copy .[a3]
                rs = .Cells(Rows.Count, 1).End(xlUp).Row - 1
                .[a2].Resize(rs, 7).Borders.LineStyle = 1
            End With
        Next i
        wb.Worksheets(1).Delete
        wb.SaveAs Filename:=ThisWorkbook.Path & "\考场安排数据\" & mc & sh.Name & "考场安排表"
        wb.Close
    End If
Next sh
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

Sub 生成桌贴()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim d As Object
Dim rng As Range
Dim ar As Variant
Dim br()
Set d = CreateObject("scripting.dictionary")
With ThisWorkbook.Worksheets("设置")
    mc = .[b1] & .[b2] & .[c2] & .[d2] & .[b3] & .[b4]
End With
Application.SheetsInNewWorkbook = 1
Set sht = ThisWorkbook.Worksheets("桌贴模板")
For Each sh In ThisWorkbook.Worksheets
   If sh.Name <> "设置" And sh.Name <> "考生数据库" And sh.Name <> "桌贴模板" And sh.Name <> "准考证模板" And sh.Name <> "门贴" Then
        d.RemoveAll
        Set wb = Workbooks.Add
        ar = sh.[a1].CurrentRegion
        For i = 2 To UBound(ar)
            If Trim(ar(i, 6)) <> "" Then
                d(Trim(ar(i, 6))) = ""
            End If
        Next i
        For Each K In d.keys
            n = 0
            ReDim br(1 To UBound(ar), 1 To 7)
            For i = 2 To UBound(ar)
                If Trim(ar(i, 6)) = K Then
                    n = n + 1
                    For j = 1 To UBound(ar, 2)
                        br(n, j) = ar(i, j)
                    Next j
                End If
            Next i
            sht.Copy after:=wb.Worksheets(wb.Worksheets.Count)
            With wb.Worksheets(wb.Worksheets.Count)
               .Name = K & "考场"
               If n / 2 = Int(n / 2) Then
                    sl = n / 2
                Else
                    sl = Int(n / 2) + 1
                End If
                m = 6
                For i = 2 To sl
                    .Rows("1:5").Copy .Cells(m, 1)
                    m = m + 5
                Next i
                m = 1
                For i = 1 To n Step 2
                    .Cells(m, 2) = br(i, 2)
                    .Cells(m, 4) = br(i, 5)
                    .Cells(m + 1, 2) = br(i, 3)
                    .Cells(m + 1, 4) = br(i, 6)
                    .Cells(m + 2, 2) = br(i, 7)
                    .Cells(m + 3, 2) = br(i, 4)
                    
                    .Cells(m, 7) = br(i + 1, 2)
                    .Cells(m, 9) = br(i + 1, 5)
                    .Cells(m + 1, 7) = br(i + 1, 3)
                    .Cells(m + 1, 9) = br(i + 1, 6)
                    .Cells(m + 2, 7) = br(i + 1, 7)
                    .Cells(m + 3, 7) = br(i + 1, 4)
                    m = m + 5
                Next i
            End With
        Next K
        wb.Worksheets(1).Delete
        wb.SaveAs Filename:=ThisWorkbook.Path & "\考场安排数据\" & mc & sh.Name & "桌面贴条"
        wb.Close
    End If
Next sh
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

Sub 生成准考证()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim d As Object
Dim rng As Range
Dim ar As Variant
Dim br()
Set d = CreateObject("scripting.dictionary")
With ThisWorkbook.Worksheets("设置")
    mc = .[b1] & .[b2] & .[c2] & .[d2] & .[b3] & .[b4]
End With
Application.SheetsInNewWorkbook = 1
Set sht = ThisWorkbook.Worksheets("准考证模板")
For Each sh In ThisWorkbook.Worksheets
    If sh.Name <> "设置" And sh.Name <> "考生数据库" And sh.Name <> "桌贴模板" And sh.Name <> "准考证模板" And sh.Name <> "门贴" Then
        d.RemoveAll
        Set wb = Workbooks.Add
        ar = sh.[a1].CurrentRegion
        For i = 2 To UBound(ar)
            If Trim(ar(i, 2)) <> "" Then
                d(Trim(ar(i, 2))) = ""
            End If
        Next i
        For Each K In d.keys
            If Trim(K) <> "" Then
                n = 0
                ReDim br(1 To UBound(ar), 1 To 7)
                For i = 2 To UBound(ar)
                    If Trim(ar(i, 2)) = K Then
                        n = n + 1
                        For j = 1 To UBound(ar, 2)
                            br(n, j) = ar(i, j)
                        Next j
                    End If
                Next i
                sht.Copy after:=wb.Worksheets(wb.Worksheets.Count)
                With wb.Worksheets(wb.Worksheets.Count)
                   .Name = K & "班"
                   If n / 2 = Int(n / 2) Then
                        sl = n / 2
                    Else
                        sl = Int(n / 2) + 1
                    End If
                    m = 10
                    For i = 2 To sl
                        .Rows("1:9").Copy .Cells(m, 1)
                        m = m + 9
                    Next i
                    m = 3
                    For i = 1 To n Step 2
                        .Cells(m, 2) = br(i, 2)
                        .Cells(m + 1, 2) = br(i, 3)
                        .Cells(m + 2, 2) = br(i, 7)
                        .Cells(m + 3, 2) = br(i, 5)
                        .Cells(m + 4, 2) = br(i, 6)
                        .Cells(m + 4, 4) = br(i, 4)
                         fs1 = Dir(ThisWorkbook.Path & "\学生照片\" & CStr(br(i, 3)) & ".jpg")
                         If fs1 <> "" Then
                             .Range("d" & m & ":D" & m + 3).Select
                             ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\学生照片\" & fs1).Select
                             Selection.ShapeRange.LockAspectRatio = msoFalse
                                Selection.ShapeRange.Top = .Range("d" & m & ":D" & m + 3).Top + 1
                                Selection.ShapeRange.Left = .Range("d" & m & ":D" & m + 3).Left + 1
                                Selection.ShapeRange.Width = .Range("d" & m & ":D" & m + 3).Width
                                Selection.ShapeRange.Height = .Range("d" & m & ":D" & m + 3).Height
                        End If
                             
                        .Cells(m, 7) = br(i + 1, 2)
                        .Cells(m + 1, 7) = br(i + 1, 3)
                        .Cells(m + 2, 7) = br(i + 1, 7)
                        .Cells(m + 3, 7) = br(i + 1, 5)
                        .Cells(m + 4, 7) = br(i + 1, 6)
                        .Cells(m + 4, 9) = br(i + 1, 4)
                         fs2 = Dir(ThisWorkbook.Path & "\学生照片\" & CStr(br(i + 1, 3)) & ".jpg")
                         If fs2 <> "" Then
                             .Range("i" & m & ":i" & m + 3).Select
                             ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\学生照片\" & fs2).Select
                             Selection.ShapeRange.LockAspectRatio = msoFalse
                                Selection.ShapeRange.Top = .Range("i" & m & ":i" & m + 3).Top + 1
                                Selection.ShapeRange.Left = .Range("i" & m & ":i" & m + 3).Left + 1
                                Selection.ShapeRange.Width = .Range("i" & m & ":i" & m + 3).Width
                                Selection.ShapeRange.Height = .Range("i" & m & ":i" & m + 3).Height
                        End If
                        m = m + 9
                    Next i
                End With
            End If
        Next K
        wb.Worksheets(1).Delete
        wb.SaveAs Filename:=ThisWorkbook.Path & "\考场安排数据\" & mc & sh.Name & "准考证"
        wb.Close
    End If
Next sh
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

Sub 打印门贴()
With Sheets("门贴")
    r = .Cells(Rows.Count, "w").End(xlUp).Row
    ar = .Range("w1:x" & r)
    For i = 1 To 1 'UBound(ar)
        If Trim(ar(i, 1)) <> "" And Trim(ar(i, 2)) <> "" Then
            .[e12] = ar(i, 1)
            .[e19] = ar(i, 2) & "人"
            .PrintOut
        End If
    Next i
End With
End Sub
Sub 生成登分表()
Application.ScreenUpdating = False
With Sheets("设置")
    y = .Cells(6, Columns.Count).End(xlToLeft).Column
    If y < 2 Then MsgBox "请先设置考试科目！": Exit Sub
    rr = .Range(.Cells(6, 2), .Cells(6, y))
    mc = .[b1] & .[b2] & .[c2] & .[d2] & .[b3] & .[b4]
End With
For Each sh In ThisWorkbook.Worksheets
    If sh.Name <> "设置" And sh.Name <> "考生数据库" And sh.Name <> "桌贴模板" And sh.Name <> "准考证模板" And sh.Name <> "门贴" Then
        sh.Copy
        With ActiveWorkbook.Worksheets(1)
            .[h1].Resize(1, UBound(rr, 2)) = rr
            r = .Cells(Rows.Count, 1).End(xlUp).Row
            .Range(.Cells(1, 1), .Cells(r, y + 6)).Borders.LineStyle = 1
        End With
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\考场安排数据\" & mc & sh.Name & "登分表"
        ActiveWorkbook.Close
    End If
Next sh
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub