学生考场安排模板

鱼中雨

功能：

1、可以先预设某几个学生的考场位置
2、随机打散学生
3、可以生成考场安排表，班级安排表和考场桌贴
4、可以自由设定每个考场的安排人数
5、会自动在文件同一个路径下生成一个文件夹，考场安排表，班级安排表和考场桌贴都在这个文件夹内
考场安排有预设.rar

碧蓝海天

Sub 考场安排()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant, arr As Variant
Dim i As Long, r As Long, rs As Long
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
tt = Timer
With Sheets("设置")
    r = .Cells(Rows.Count, 4).End(xlUp).Row
    If r < 2 Then MsgBox &quot;请先设置考场号和考场人数！&quot;: End
    ar = .Range(&quot;d1&quot;).Resize(r, 2)
    mc = .[b1] & .[b2] & &quot;学年度&quot; & .[b3] & .[b4] & &quot;考场安排表&quot;
End With
With Sheets(&quot;考生数据&quot;)
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    If rs < 2 Then MsgBox &quot;考生数据为空！&quot;: End
    arr = .Range(&quot;a1&quot;).Resize(rs, 5)
End With
With Sheets(&quot;考场安排&quot;)
    With .UsedRange.Offset(1)
        .Value = Empty
        .Borders.LineStyle = 0
    End With
    With .[a2].Resize(UBound(arr), UBound(arr, 2))
        .Value = arr
    End With
    .[a2].Resize(UBound(arr), UBound(arr, 2) + 3).Borders.LineStyle = 1
    .[f2].Resize(1, 3) = Array(&quot;考号&quot;, &quot;考场号&quot;, &quot;座位号&quot;)
    br = .Range(&quot;a3&quot;).Resize(rs - 1, 8)
    '使用Fisher-Yates洗牌算法随机打散
    Randomize ' 初始化随机数生成器
    For i = UBound(br) To 2 Step -1
        s = Int((i - 1) * Rnd) + 1 '生成1到i-1的随机数
        '交换行数据
        For j = 1 To UBound(br, 2) '
            temp = br(i, j)
            br(i, j) = br(s, j)
            br(s, j) = temp
        Next j
    Next i
    .[a1] = mc
    nn = 0: dc.RemoveAll
    For i = 2 To UBound(br)
        If Not d.exists(br(i, 4)) Then
            nn = nn + 1
            d(br(i, 4)) = nn
        End If
    Next i
    For i = 2 To UBound(br)
        br(i, 6) = d(br(i, 4))
        d(br(i, 4)) = d(br(i, 4)) + d.Count
    Next i
    For i = 2 To UBound(br)
        For s = i + 1 To UBound(br)
            If br(i, 6) > br(s, 6) 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
        If br(i, 5)  &quot;&quot; Then dc(br(i, 5)) = i
    Next i
    m = 2
    For i = 2 To UBound(ar)
        If ar(i, 1)  &quot;&quot; Then
            s = 0
            m = m - 1
            For w = 1 To ar(i, 2) + 10
                m = m + 1
                If m > UBound(br) Then GoTo 20
                If br(m, 5) = &quot;&quot; Then
                    s = s + 1
                    zf = Format(ar(i, 1), &quot;00&quot;) & Format(s, &quot;00&quot;)
                    If dc.exists(zf) Then
                        s = s + 1
                    Else
                        s = s
                    End If
                    If s > ar(i, 2) Then GoTo 10
                    br(m, 7) = Format(ar(i, 1), &quot;00&quot;)
                    br(m, 8) = Format(s, &quot;00&quot;)
                    br(m, 6) = br(m, 7) & br(m, 8)
                Else
                    br(m, 6) = br(m, 5)
                    br(m, 7) = Left(br(m, 5), 2)
                    br(m, 8) = Right(br(m, 5), 2)
                End If
            Next w
10:
        End If
    Next i
20:
    .Columns(&quot;A:H&quot;).NumberFormatLocal = &quot;@&quot;
    .Range(&quot;a3&quot;).Resize(rs - 1, 8) = br
    .Range(&quot;a2&quot;).Resize(rs, 8).Sort .[f2], 1, , , , , , 1 '按考号排序
    .Columns(5).Delete
    .Columns(&quot;F:G&quot;).HorizontalAlignment = xlHAlignCenter
    .Activate
End With
Set d = Nothing
Set dc = Nothing
Application.ScreenUpdating = True
MsgBox &quot;耗时：&quot; & Format(Timer - tt, &quot;0.00&quot;) & &quot;秒！&quot;
End Sub

正阳电脑

感谢大佬分享

信杰廉悍

感谢老师的分享

天安子

谢谢分享！

坏坏惹人爱

老大，我在你发的考场安排的基础上删除了学号，也改了考号的形式，座位贴也改了符合我校的考场安排习惯，请帮我改下对应的VBA,谢谢啦！考场安排有预设.rar

余生一起

代码还有点问题，不能根据设置的人数进行分考场，比如242人共分6个考场，每考场40人，最后一个考场应为42人。但又从第7考场开始了，超出了设置的6个考场。请教！！

终南之巅

你这个问题问的有点那个.....
242人,每考场40人,必须有7个呀..
要么设置考场数,要么设置每场人数,二选一.

华铭

要么你对教务工作还不是非常熟悉，要么你没有认真的熟悉功能，242人，分6个考场，每个考场40人，总数是420人，余数是2人，关键是你要在设置中设置各个考场人数呀，

瘾丶

你至少要明确告诉我，按你校的习惯，目前还存在的问题是什么。我才能有针对性的去修改代码的呀