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

chxw68

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

你提的这个建议也可行，就怕数据太少使程序陷入死循环，比如只有两个班，一个班比另一个班多两个以上人员，这样怎么排列都会有一个班的两个学生相邻，程序就会进入死循环。

烟松粼

先手工找乱，再用程序排

捞屎人

加一列辅助列产生随机数  然后再排序就是了
但是细审问题感觉你要的不是随机排序 而是班级穿插

呵呵  中小学考场编排 我最专业

1. Public Function 考场模式(rng As Range, lie1%, moshi$, Optional biaotihang = 0)  '根据不同的模式对考生排序
   
2.     Dim i&, j&, arr, brr, dic As Object, key, lie%
   
3.     j = 1
   
4.     With rng
   
5.         lie = IIf(lie1 < 0, .Columns.Count, lie1)
   
6.         Select Case moshi
   
7.             Case "按成绩降序" '按成绩降序排考场
   
8.                 .Sort key1:=.Cells(1, lie), order1:=2, Header:=2 - biaotihang '数据源按成绩降序排序
   
9.                 考场模式 = 1
   
10.                 Exit Function
    
11.             Case "按班级升序" '按班级不打散排考场
    
12.                 .Sort key1:=.Cells(1, 2), order1:=1, key2:=.Cells(1, lie), order2:=2, Header:=2 - biaotihang '数据源按班级升序/成绩降序排序
    
13.                 arr = .Value '载入年级人数
    
14.                 For i = 1 To .Rows.Count '遍历所有学生
    
15.                     If arr(i, Abs(lie1)) <> "" Then
    
16.                         arr(i, Abs(lie1)) = j '如果成绩不为空,则编号
    
17.                         j = j + 1
    
18.                     End If
    
19.                 Next
    
20.                 考场模式 = 2
    
21.             Case "按班级交叉" '按班级均匀交叉排考场
    
22.                 .Sort key1:=.Cells(1, 2), order1:=1, key2:=.Cells(1, lie), order2:=2, Header:=2 - biaotihang '数据源按班级升序/成绩降序排序
    
23.                 Set dic = 分段(rng, 2, 1) '计算各班考生起止位置
    
24.                 i = 1
    
25.                 arr = .Value '载入年级人数
    
26.                 While dic.Count
    
27.                     For Each key In dic '遍历各班
    
28.                         brr = dic(key)
    
29.                         If arr(brr(1), Abs(lie1)) <> "" Then
    
30.                             arr(brr(1), Abs(lie1)) = j '从各班取出一个人编号
    
31.                             j = j + 1
    
32.                         End If
    
33.                         i = i + 1
    
34.                         If brr(1) = brr(2) Then '如果班级人员取完
    
35.                             dic.Remove (key) '移除字典
    
36.                         Else
    
37.                             brr(1) = brr(1) + 1 '班级起始位置下移一位
    
38.                             dic(key) = brr
    
39.                         End If
    
40.                     Next
    
41.                 Wend
    
42.                 考场模式 = 3
    
43.             Case Else
    
44.                 考场模式 = 0
    
45.         End Select
    
46.         .Value = arr
    
47.         .Sort key1:=.Cells(1, Abs(lie1)), order1:=1, Header:=2 - biaotihang
    
48.     End With
    
49. End Function

复制代码