VBA考试安排8778座次表

张祥荣

此表中的座次表不能按照预设的考场人数生成，请各位高手帮助解决里面的两个问题，谢谢！
VBA考试安排8778.zip (359.19 KB, 下载次数: 69)

2014-12-23 19:31 上传

点击文件名下载附件

chxw68

看了看附件中的代码，该代码在设计之初就没考虑按每个试场人数安排考生，而是统一按每个考场30人安排的，现在修改起来比较麻烦。

m_n_j001

这来自EP，哈哈
没看明白是哪里没对？生成的考场、座号、分班都是对的呀。

feiren228

代码没有问题啊

feiren228

原来你是讲生成座次表的问题？？

feiren228

测试》》》》
VBA考试安排_feiren228.zip (384.04 KB, 下载次数: 54)

2014-12-24 00:54 上传

点击文件名下载附件

VBA考试安排_feiren228_V3.rar (248.28 KB, 下载次数: 71)

2014-12-24 13:23 上传

点击文件名下载附件
V3

feiren228

1. Sub 生成座次表() 'by feiren228
   
2.     Application.DisplayAlerts = False '不提示
   
3.     Application.ScreenUpdating = False '不刷新
   
4.     With Sheets("考生信息")
   
5.         Row1 = .Range("a" & .Rows.Count).End(xlUp).Row '考生信息的最后一行行号
   
6.         ks = .Range("a2:e" & Row1) '考生信息赋予数组
   
7.     End With
   
8.     With Sheets("考场信息") '同上考场信息赋予数组
   
9.         Row2 = .Range("a" & .Rows.Count).End(xlUp).Row
   
10.         kc = .Range("a2:c" & Row2)
    
11.     End With
    
12.     For Each sht In Sheets '扫描每一个工作表
    
13.         If sht.Name Like "试场*" Then '是考场工作表就删除
    
14.         sht.Delete
    
15.     End If
    
16. Next
    
17. For n = 1 To UBound(kc)
    
18.     k = Int(kc(n, 2) / 4)
    
19.     k0 = kc(n, 2) Mod 4
    
20.     ps = Array(k, k, k, k)
    
21.     For x = 0 To k0 - 1
    
22.         ps(x) = ps(x) + 1
    
23.     Next
    
24.     c0 = ps(0): c1 = ps(1): c2 = ps(2): c3 = ps(3)
    
25.     ReDim tempar(1 To ps(0), 1 To 12)
    
26.     For i = 1 To UBound(ks)
    
27.         If ks(i, 3) = kc(n, 1) Then
    
28.             m = m + 1
    
29.             Select Case m
    
30.             Case Is <= c0
    
31.                 tempar(m, 1) = (ks(i, 1))
    
32.                 tempar(m, 2) = (ks(i, 2))
    
33.                 tempar(m, 3) = (ks(i, 4))
    
34.             Case Is <= c0 + c1
    
35.                 tempar(ps(1), 4) = (ks(i, 1))
    
36.                 tempar(ps(1), 5) = (ks(i, 2))
    
37.                 tempar(ps(1), 6) = (ks(i, 4))
    
38.                 ps(1) = ps(1) - 1
    
39.             Case Is <= c0 + c1 + c2
    
40.                 y = y + 1
    
41.                 tempar(y, 7) = (ks(i, 1))
    
42.                 tempar(y, 8) = (ks(i, 2))
    
43.                 tempar(y, 9) = (ks(i, 4))
    
44.             Case Is <= c0 + c1 + c2 + c3
    
45.                 tempar(ps(3), 10) = (ks(i, 1))
    
46.                 tempar(ps(3), 11) = (ks(i, 2))
    
47.                 tempar(ps(3), 12) = (ks(i, 4))
    
48.                 ps(3) = ps(3) - 1
    
49.             End Select
    
50.         End If
    
51.     Next i
    
52.     Sheets("座次表").Copy after:=Sheets(Sheets.Count) '复制“座次表”到最后
    
53.     With Sheets(Sheets.Count) '针对最后一个工作表
    
54.         .Name = "试场" & n '更名
    
55.         .Range("A5").Resize(UBound(tempar), 12) = tempar
    
56.         Erase tempar
    
57.         '.Range("D5:F" & ps(1) + 4).Sort key1:=[F4], Order1:=xlDescending
    
58.        ' .Range("J5:L" & ps(3) + 4).Sort key1:=[L4], Order1:=xlDescending
    
59.        ' .Range("G5:I" & ps(2) + 4).Sort key1:=[I4], Order1:=xlAscending
    
60.         .[F1] = n
    
61.         .[c2] = kc(n, 3)
    
62.         .[I2] = [A5] & "至" & [J5]
    
63.     End With
    
64.     m = 0: y = 0
    
65. Next n
    
66. Application.DisplayAlerts = True '恢复提示
    
67. Application.ScreenUpdating = True '恢复刷屏
    
68. End Sub
    

复制代码

dyzx

feiren228 发表于 2014-12-24 00:57

feiren228老师：生成考场号和座号有问题，不能按考场信息设置的人数去排考场号和座号，请指教，多谢

feiren228

dyzx 发表于 2014-12-24 13:19
feiren228老师：生成考场号和座号有问题，不能按考场信息设置的人数去排考场号和座号，请指教，多谢

没有问题！按步骤来，【考号】表先清除考号，重新生成考号，再到【考生信息】里依次操作执行，即可

dyzx

feiren228 发表于 2014-12-24 13:28
没有问题！按步骤来，【考号】表先清除考号，重新生成考号，再到【考生信息】里依次操作执行，即可

feiren228老师：一点生成考场座号键就出现对话框“下标越有-界”，同时这句显示黄色brr(s, 1) = arr(m, 1)请指教，多谢