新高考下，求助考场编排。

过客fppt · 发表于 2024-4-13 22:18

有点好奇，这么重要的问题，国家教育部门没有开发对应的程序吗

戎马书生222 · 发表于 2024-4-14 05:49

这是平时学校月考用的。高考监考安排肯定有啊。

戎马书生222 · 发表于 2024-4-14 07:56

chxw68 发表于 2024-4-13 22:12
详见附件。

感谢帮忙！太谢谢了，以后月考省力了。

戎马书生222 · 发表于 2024-4-15 06:52

本帖最后由戎马书生222 于 2024-4-15 06:56 编辑

chxw68 发表于 2024-4-13 22:12
详见附件。

你好，点了排考场后，怎么把右边的N列到V列也给清除了内容。要实现右边区域的功能，该如何实现?

谢谢了！！！

chxw68 · 发表于 2024-4-15 08:57

Sub vba排考场()
Dim r%, i%
Dim arr, brr
Dim d(0 To 2) As Object
Dim vs As Variant
Dim d1 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Dim kaochangrenshu As Integer '定义了一个标准考场的人数
Application.ScreenUpdating = False
Application.DisplayAlerts = False
vs = Array(Array("英", "日", "西"), Array("物化", "政史"), Array("生", "地"))
For k = 0 To 2
Set d(k) = CreateObject("scripting.dictionary")
Next
kaochangrenshu = Application.InputBox(prompt:="请输入一个标准考场的人数", Title:="输入标准人数", Default:=45, Type:=1)
With Worksheets("vba排考场")
.AutoFilterMode = False
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range("f2:s" & r).ClearContents
.Range("t3:v" & r).ClearContents
.Range("u3:u" & .Rows.Count).NumberFormatLocal = "@"
arr = .Range("a2:m" & r)
m = 0
For k = 1 To UBound(arr) Step kaochangrenshu
If UBound(arr) - k + 1 > 8 Then
m = m + 1
End If
For q = 1 To Application.Min(UBound(arr) - k + 1, kaochangrenshu)
x = k + q - 1
arr(x, 6) = m
If UBound(arr) - k + 1 > 8 Then
arr(x, 7) = q
Else
arr(x, 7) = kaochangrenshu + q
End If
If Not d1.exists(m) Then
ReDim brr(1 To 5)
brr(1) = m
Else
brr = d1(m)
End If
brr(2) = brr(2) + 1
d1(m) = brr
If Not d2.exists("语数") Then
ReDim crr(1 To 3)
crr(1) = "语数"
crr(2) = Array(0, 0)
Else
crr = d2("语数")
End If
If crr(2)(0) = 0 Then
crr(2)(0) = m
End If
crr(2)(1) = m
crr(3) = arr(x, 7)
d2("语数") = crr
Next
Next
For i = 1 To UBound(arr)
If Not d(0).exists(arr(i, 4)) Then
Set d(0)(arr(i, 4)) = CreateObject("scripting.dictionary")
End If
d(0)(arr(i, 4))(i) = Empty
km = Left(arr(i, 3), 2)
If Not d(1).exists(km) Then
Set d(1)(km) = CreateObject("scripting.dictionary")
End If
d(1)(km)(i) = Empty
km = Right(arr(i, 3), 1)
If Not d(2).exists(km) Then
Set d(2)(km) = CreateObject("scripting.dictionary")
End If
d(2)(km)(i) = Empty
Next
y = 6
For w = 0 To UBound(vs)
y = y + 2
m = 0
For u = 0 To UBound(vs(w))
aa = vs(w)(u)
If d(w).exists(aa) Then
kk = d(w)(aa).keys
For k = 0 To UBound(kk) Step kaochangrenshu
If UBound(kk) - k + 1 > 8 Then
m = m + 1
End If
For q = 1 To Application.Min(UBound(kk) - k + 1, kaochangrenshu)
x = kk(k + q - 1)
arr(x, y) = m
If UBound(kk) - k + 1 > 8 Then
arr(x, y + 1) = q
Else
arr(x, y + 1) = kaochangrenshu + q
End If
If Not d1.exists(m) Then
ReDim brr(1 To 5)
brr(1) = m
Else
brr = d1(m)
End If
brr(w + 3) = brr(w + 3) + 1
d1(m) = brr
xm = vs(w)(u)
If Not d2.exists(xm) Then
ReDim crr(1 To 3)
crr(1) = xm
crr(2) = Array(0, 0)
Else
crr = d2(xm)
End If
If crr(2)(0) = 0 Then
crr(2)(0) = m
End If
crr(2)(1) = m
crr(3) = arr(x, y + 1)
d2(xm) = crr
Next
Next
End If
Next
Next
ReDim drr(1 To d2.Count, 1 To 3)
m = 0
For Each aa In d2.keys
crr = d2(aa)
crr(2) = crr(2)(0) & "-" & crr(2)(1)
m = m + 1
For j = 1 To UBound(crr)
drr(m, j) = crr(j)
Next
Next
.Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
.Range("o2").Resize(d1.Count, UBound(brr)) = Application.Transpose(Application.Transpose(d1.items))
.Range("t3").Resize(UBound(drr), UBound(drr, 2)) = drr
End With
Application.ScreenUpdating = True
MsgBox "考场排列完毕！"
End Sub

复制代码

chxw68 · 发表于 2024-4-15 08:58

修改好了。

ooluckydog · 发表于 2024-4-15 13:41

凑个热闹。随机生成考场安排

sunshuangzhong · 发表于 2024-4-16 08:48

楼主这个排考场，有没有考虑到不同选科在不考试的时间，学生回本班级自修呢。比如：物生地选科的考生在不考史化政的时间段内要回本班级自修，却发现本班被别的选科考试占用了教室呢。

戎马书生222 · 发表于 2024-4-16 09:55

sunshuangzhong 发表于 2024-4-16 08:48
楼主这个排考场，有没有考虑到不同选科在不考试的时间，学生回本班级自修呢。比如：物生地选科的考生在不考 ...

没有你说的情况。我校这边物理化学捆绑，相当于一门学科。政治历史捆绑，相当于一门学科。只开设了4个组合。分别是物化生，物化地；政史生，政史地。

戎马书生222 · 发表于 2024-4-16 10:27

ooluckydog 发表于 2024-4-15 13:41
凑个热闹。随机生成考场安排

感谢。太好用了。学校平常周考排考场一般都是按照成绩由高到低排，只有在期末，县级联考时才用随机排考场。能否添加一下各个学科的考场数和尾考场人数。如图

		自动登录	找回密码
密码			免费注册

[求助] 新高考下，求助考场编排。

评分

评分

评分