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

过客fppt

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

戎马书生222

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

戎马书生222

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

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

戎马书生222

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

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

谢谢了！！！

chxw68

1. Sub vba排考场()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d(0 To 2) As Object
   
5.     Dim vs As Variant
   
6.     Dim d1 As Object
   
7.     Set d1 = CreateObject("scripting.dictionary")
   
8.     Set d2 = CreateObject("scripting.dictionary")
   
9.     Dim kaochangrenshu As Integer  '定义了一个标准考场的人数
   
10.     Application.ScreenUpdating = False
    
11.     Application.DisplayAlerts = False
    
12.     vs = Array(Array("英", "日", "西"), Array("物化", "政史"), Array("生", "地"))
    
13.     For k = 0 To 2
    
14.         Set d(k) = CreateObject("scripting.dictionary")
    
15.     Next
    
16.     kaochangrenshu = Application.InputBox(prompt:="请输入一个标准考场的人数", Title:="输入标准人数", Default:=45, Type:=1)
    
17.     With Worksheets("vba排考场")
    
18.         .AutoFilterMode = False
    
19.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
20.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
21.         .Range("f2:s" & r).ClearContents
    
22.         .Range("t3:v" & r).ClearContents
    
23.         .Range("u3:u" & .Rows.Count).NumberFormatLocal = "@"
    
24.         arr = .Range("a2:m" & r)
    
25.         m = 0
    
26.         For k = 1 To UBound(arr) Step kaochangrenshu
    
27.             If UBound(arr) - k + 1 > 8 Then
    
28.                 m = m + 1
    
29.             End If
    
30.             For q = 1 To Application.Min(UBound(arr) - k + 1, kaochangrenshu)
    
31.                 x = k + q - 1
    
32.                 arr(x, 6) = m
    
33.                 If UBound(arr) - k + 1 > 8 Then
    
34.                     arr(x, 7) = q
    
35.                 Else
    
36.                     arr(x, 7) = kaochangrenshu + q
    
37.                 End If
    
38.                 If Not d1.exists(m) Then
    
39.                     ReDim brr(1 To 5)
    
40.                     brr(1) = m
    
41.                 Else
    
42.                     brr = d1(m)
    
43.                 End If
    
44.                 brr(2) = brr(2) + 1
    
45.                 d1(m) = brr
    
46.                 If Not d2.exists("语数") Then
    
47.                     ReDim crr(1 To 3)
    
48.                     crr(1) = "语数"
    
49.                     crr(2) = Array(0, 0)
    
50.                 Else
    
51.                     crr = d2("语数")
    
52.                 End If
    
53.                 If crr(2)(0) = 0 Then
    
54.                     crr(2)(0) = m
    
55.                 End If
    
56.                 crr(2)(1) = m
    
57.                 crr(3) = arr(x, 7)
    
58.                 d2("语数") = crr
    
59.                
    
60.                     
    
61.             Next
    
62.         Next
    
63.                         
    
64.         For i = 1 To UBound(arr)
    
65.             If Not d(0).exists(arr(i, 4)) Then
    
66.                 Set d(0)(arr(i, 4)) = CreateObject("scripting.dictionary")
    
67.             End If
    
68.             d(0)(arr(i, 4))(i) = Empty
    
69.             km = Left(arr(i, 3), 2)
    
70.             If Not d(1).exists(km) Then
    
71.                 Set d(1)(km) = CreateObject("scripting.dictionary")
    
72.             End If
    
73.             d(1)(km)(i) = Empty
    
74.             km = Right(arr(i, 3), 1)
    
75.             If Not d(2).exists(km) Then
    
76.                 Set d(2)(km) = CreateObject("scripting.dictionary")
    
77.             End If
    
78.             d(2)(km)(i) = Empty
    
79.         Next
    
80.         y = 6
    
81.         For w = 0 To UBound(vs)
    
82.             y = y + 2
    
83.             m = 0
    
84.             For u = 0 To UBound(vs(w))
    
85.                 aa = vs(w)(u)
    
86.                 If d(w).exists(aa) Then
    
87.                     kk = d(w)(aa).keys
    
88.                     For k = 0 To UBound(kk) Step kaochangrenshu
    
89.                         If UBound(kk) - k + 1 > 8 Then
    
90.                             m = m + 1
    
91.                         End If
    
92.                         For q = 1 To Application.Min(UBound(kk) - k + 1, kaochangrenshu)
    
93.                             x = kk(k + q - 1)
    
94.                             arr(x, y) = m
    
95.                             If UBound(kk) - k + 1 > 8 Then
    
96.                                 arr(x, y + 1) = q
    
97.                             Else
    
98.                                 arr(x, y + 1) = kaochangrenshu + q
    
99.                             End If
    
100.                             If Not d1.exists(m) Then
     
101.                                 ReDim brr(1 To 5)
     
102.                                 brr(1) = m
     
103.                             Else
     
104.                                 brr = d1(m)
     
105.                             End If
     
106.                             brr(w + 3) = brr(w + 3) + 1
     
107.                             d1(m) = brr
     
108.                            
     
109.                             xm = vs(w)(u)
     
110.                             If Not d2.exists(xm) Then
     
111.                                 ReDim crr(1 To 3)
     
112.                                 crr(1) = xm
     
113.                                 crr(2) = Array(0, 0)
     
114.                             Else
     
115.                                 crr = d2(xm)
     
116.                             End If
     
117.                             If crr(2)(0) = 0 Then
     
118.                                 crr(2)(0) = m
     
119.                             End If
     
120.                             crr(2)(1) = m
     
121.                             crr(3) = arr(x, y + 1)
     
122.                             d2(xm) = crr
     
123.                         Next
     
124.                     Next
     
125.                 End If
     
126.             Next
     
127.         Next
     
128.         ReDim drr(1 To d2.Count, 1 To 3)
     
129.         m = 0
     
130.         For Each aa In d2.keys
     
131.             crr = d2(aa)
     
132.             crr(2) = crr(2)(0) & "-" & crr(2)(1)
     
133.             m = m + 1
     
134.             For j = 1 To UBound(crr)
     
135.                 drr(m, j) = crr(j)
     
136.             Next
     
137.         Next
     
138.             
     
139.         .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
     
140.         .Range("o2").Resize(d1.Count, UBound(brr)) = Application.Transpose(Application.Transpose(d1.items))
     
141.         .Range("t3").Resize(UBound(drr), UBound(drr, 2)) = drr
     
142.     End With
     
143.     Application.ScreenUpdating = True
     
144.     MsgBox "考场排列完毕！"
     
145. End Sub
     
146. 
     
147. 
     

复制代码

chxw68

修改好了。

ooluckydog

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

sunshuangzhong

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

戎马书生222

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

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

戎马书生222

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

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