想求一个排考场考号程序

洛紫彧

想求一个排考场考号程序，

学校会提供A列到G列的内容，然后程序会按照学校名称，打乱考生顺序排列考场和座位，考场人数可以根据学校自定义人数，最后生成考号，A到F列可以自定义变更顺序的组合

3190496160

考场安排的问题，这几年研究的多了，自己手里也有比较成熟的考场安排模板，只是你的考号的生成方式跟我们的有所不同
但是：
1.提供你的文件，要有一点具体的数据
2、A；F自定义顺序的目的是什么？感觉是多余的
3、根据ABCDEFHI列编考号，具体的规则是什么？？

洛紫彧

3190496160 发表于 2020-6-9 16:02
考场安排的问题，这几年研究的多了，自己手里也有比较成熟的考场安排模板，只是你的考号的生成方式跟我们的 ...

感谢大佬回复， 我们组织考试都是区县或者市级的考试，考号的规则一般都是这些列数字的组合，有些考试可能学校代码在1~2位 有些可能在5~6位，所以不能确定考号就是固定的规则

洛紫彧

3190496160 发表于 2020-6-9 16:02
考场安排的问题，这几年研究的多了，自己手里也有比较成熟的考场安排模板，只是你的考号的生成方式跟我们的 ...

这是一份考生数据，以学校打乱学生顺序安排考场。文理科另起考场

洛紫彧

3190496160 发表于 2020-6-9 16:02
考场安排的问题，这几年研究的多了，自己手里也有比较成熟的考场安排模板，只是你的考号的生成方式跟我们的 ...

大佬 能实现吗？ 这边花点钱也行

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Application.ScreenUpdating = False
   
7.   Application.DisplayAlerts = False
   
8.   Randomize Timer
   
9.   rs = Application.InputBox(prompt:="请输入每个考室人数", Title:="操作提示", Default:=30, Type:=1)
   
10.   If rs = False Then
    
11.     MsgBox "没有输入考室人数！"
    
12.     Exit Sub
    
13.   End If
    
14.   With Worksheets("学生信息")
    
15.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
16.     arr = .Range("a2:g" & r)
    
17.     For i = 1 To UBound(arr)
    
18.       If Not d.exists(arr(i, 7)) Then
    
19.         Set d(arr(i, 7)) = CreateObject("scripting.dictionary")
    
20.       End If
    
21.       If Not d(arr(i, 7)).exists(arr(i, 1)) Then
    
22.         Set d(arr(i, 7))(arr(i, 1)) = CreateObject("scripting.dictionary")
    
23.       End If
    
24.       d(arr(i, 7))(arr(i, 1))(i) = ""
    
25.     Next
    
26.     ReDim brr(1 To UBound(arr), 1 To 3)
    
27.     For Each aa In d.keys
    
28.       For Each bb In d(aa).keys
    
29.         m = 1
    
30.         n = 1
    
31.         kk = d(aa)(bb).keys
    
32.         For i = 0 To UBound(kk) - 1
    
33.           x = Int((UBound(kk) - i) * Rnd()) + i + 1
    
34.           temp = kk(i)
    
35.           kk(i) = kk(x)
    
36.           kk(x) = temp
    
37.         Next
    
38.         For i = 0 To UBound(kk)
    
39.           brr(kk(i), 1) = m
    
40.           brr(kk(i), 2) = n
    
41.           brr(kk(i), 3) = arr(kk(i), 1) & arr(kk(i), 2) & arr(kk(i), 4) & arr(kk(i), 5) & arr(kk(i), 6) & Format(m, "00") & Format(n, "00")
    
42.           n = n + 1
    
43.           If n > rs Then
    
44.             m = m + 1
    
45.             n = 1
    
46.           End If
    
47.         Next
    
48.       Next
    
49.     Next
    
50.     .Columns(10).NumberFormatLocal = "@"
    
51.     .Range("h2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
52.             
    
53.   End With
    
54. End Sub
    

复制代码

chxw68

详见附件。

chxw68

这个可以按学校定义考场人数。

3190496160

看楼主的附件，有河口，建水，金平，应该是云南省红河州的吧，还是老乡呢
虽然前面的大侠已经给出了两个不同的解决方案，但是，个人觉得，既然是这么多的学校，考场安排好后，应该是需要分发到各个学校的吧，所以，暂时理了一个思路，首先按学校和文理科拆分为不同的工作表，然后，再批量以工作表为单位安排考场，再加个批量按学校拆分的按钮，拆分为一个学校一个工作簿文件，这样，安排好后，就可以方便分发到各个学校了，
所以，先把第一个步骤的解决方案贴上来，如果楼主愿意接受这个方案的话，再考虑后续的代码吧