考生打乱顺序，并按要求安排考场

522236128

请各位老师帮帮忙！！ 原打乱顺序模块当班数少时还是有很多同班学生考号是连续的，请帮忙改进；
另外帮忙添加两个功能：1、统计班级人数。2、按第二个工作表的考场设定安排考场。
先谢了！！ 安排座位考场.rar (24.24 KB, 下载次数: 77)

2014-1-10 10:59 上传

点击文件名下载附件

chxw68

你的附件有问题！

522236128

没有啊，我下了，能打开

522236128

chxw68 发表于 2014-1-10 10:43
你的附件有问题！

没有啊，我下了，能打开。
多谢老师上次帮忙！
当班数少时还是有很多同班学生考号是连续的。
请老师帮忙完善一下。

chxw68

522236128 发表于 2014-1-10 10:55
没有啊，我下了，能打开。
多谢老师上次帮忙！
当班数少时还是有很多同班学生考号是连续的。

压缩文件没后缀名，打不开。

522236128

已重新上传

chxw68

1. Sub 统计人数()
   
2.   Dim cnn As New ADODB.Connection
   
3.   Dim rs As New ADODB.Recordset
   
4.   Dim sql As String
   
5.   Dim mybook As String
   
6.   mybook = ThisWorkbook.FullName
   
7.   With cnn
   
8.     .Provider = "microsoft.jet.oledb.4.0"
   
9.     .ConnectionString = "extended properties=""excel 8.0;HDR=YES;"";data source=" & mybook
   
10.     .Open
    
11.   End With
    
12.   sql = "select 班别,count(班别) from [考生$] group by 班别 order by 班别"
    
13.   rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
    
14.   With Worksheets("各考场人数设定")
    
15.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
16.     .Range("a3:b" & r).ClearContents
    
17.     .Range("a3").CopyFromRecordset rs
    
18.     r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    
19.     .Cells(r, 1) = "合计"
    
20.     .Cells(r, 2).FormulaR1C1 = "=SUM(R[" & 3 - r & "]C:R[-1]C)"
    
21.   End With
    
22. End Sub
    
23. 
    
24. Sub 排列座位()
    
25.   Dim r%, i%
    
26.   Dim arr, brr()
    
27.   Randomize Timer
    
28.   With Worksheets("考生")
    
29.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
30.     arr = .Range("a2:e" & r)
    
31.   End With
    
32.   ReDim brr(1 To UBound(arr), 1 To 5)
    
33.   For i = 1 To UBound(arr)
    
34.     arr(i, 4) = Rnd()
    
35.     arr(i, 5) = i
    
36.   Next
    
37.   With Worksheets("座位排列")
    
38.     .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
    
39.     .Range("a2:e" & r).Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range("D2"), Order2:=xlAscending, Header:=xlNo
    
40.      arr = .Range("a2:c" & r)
    
41.     .Cells.Delete
    
42.   End With
    
43.   h = UBound(arr)
    
44.   n = h \ 2
    
45.   For i = 1 To n Step 2
    
46.     For j = 1 To 3
    
47.       brr(i, j) = arr(i, j)
    
48.       brr(i + 1, j) = arr(i + n, j)
    
49.     Next
    
50.   Next
    
51.   If h Mod 2 <> 0 Then
    
52.     For j = 1 To 3
    
53.       brr(i, j) = arr(i, j)
    
54.     Next
    
55.   End If
    
56.   With Worksheets("各考场人数设定")
    
57.     r = .Cells(.Rows.Count, "f").End(xlUp).Row
    
58.     crr = .Range("f3:g" & r)
    
59.   End With
    
60.   
    
61.   m = 0
    
62.   For i = 1 To UBound(crr)
    
63.     For j = 1 To crr(i, 2)
    
64.       m = m + 1
    
65.       If m > h Then Exit Sub
    
66.       brr(m, 3) = m
    
67.       brr(m, 4) = crr(i, 1)
    
68.     Next
    
69.   Next
    
70.   With Worksheets("座位排列")
    
71.     .Range("a1").Resize(1, 4) = Array("班别", "姓名", "考号", "座位号", "考场")
    
72.     .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
73.   End With
    
74. End Sub

复制代码

chxw68

这个随机排列也是伪随机排列，就是人员之间是随机的，但班之间是相对固定的，比如1班-3班-1班-3班，不知道其他高人有什么高招没有。

522236128

能否随机排完，再判断是否有连续，有就移到不连续的地方。

chxw68

522236128 发表于 2014-1-13 10:41
能否随机排完，再判断是否有连续，有就移到不连续的地方。

我思考了很长时间，只有现在这个办法最保险、最简便了。这个程序的思路是：将所有学生按班分别随机排序，然后按班将学生平均分两部分，然后交叉分别从两部分中取人形成新的序列。这个程序还可以小改一下，就是除中间折断的那个班外，两头其他班可以分别打乱随机排序。