再求监考随机安排

wang-way

一开始的想法是把所有人按计划数放进容器，按张三6 张三5 张三4 张三3 张三2 张三1排，然后随机抽取出来排，如果冲突就重新抽。 但是到后面10几 20个就排不下。

第二次按照计数由多到少排列，张三6 李四6 汪五6 赵二5 武大5  这样排。逐个去排，冲突了就跳过。这样可以很大程度避免冲堂。代码就可以跑出来，避免冲堂和回避问题都能解决。不需要人工操作。

但是添加了随机抽以后，还是会出现冲堂或者无法回避的问题。但是人数不多大概1-3人次。 于是增加了一段对调的代码。 可以完美解决问题。

全党

蓝桥玄霜 发表于 2023-2-19 12:22
本例的情况下，每个老师计划数应该小于6，总数在370，并且不考虑回避的情况，代码还可以成功。
建议留部分 ...

烦请老师给看看，刚接触。

全党

1. Sub 试试()
   
2. Dim brr(), arr, arr1, i, j, k, ss, cs, y, 场次, 学科, rng As Range
   
3. [c7:v50].ClearFormats
   
4. Set dic = CreateObject("Scripting.Dictionary")
   
5. dic.comparemode = 1
   
6. arr = Range("y7").CurrentRegion
   
7.    For i = 1 To UBound(arr)
   
8.       For k = 1 To arr(i, 5)
   
9.          Key = arr(i, 1) & arr(i, 3) & k
   
10.          dic.Add Key, arr(i, 3) & arr(i, 1)
    
11.         Next k
    
12.     Next i
    
13.    cs = Range("c5").End(xlToRight).Column
    
14.     With WorksheetFunction
    
15.         场次 = .Transpose(WorksheetFunction.Transpose(Range("c5:v5")))
    
16.         学科 = .Transpose(WorksheetFunction.Transpose(Range("c6:v6")))
    
17.     End With
    
18.    For y = 1 To cs - 3 + 1
    
19.         arr1 = VBA.Filter(dic.keys, Trim(学科(y)), False)
    
20.         s = UBound(arr1)
    
21.         p = 场次(y)
    
22.         ReDim brr(1 To p)
    
23.           For j = 1 To p
    
24.             n = Int((s - 1 + 0) * Rnd + 0)
    
25.             t = arr1(n): arr1(n) = arr1(j - 1): arr1(j - 1) = t
    
26.            Next j
    
27.             For ss = o To p - 2
    
28.              brr(ss + 1) = dic(arr1(ss))
    
29.              dic.Remove (CStr(arr1(ss)))
    
30.             Next
    
31.              Range(Cells(7, y + 2), Cells(p + 6, y + 2)) = Excel.Application.Transpose(brr)
    
32.              Erase brr
    
33.    Next y
    
34.   Set dic = Nothing
    
35.     For i = 3 To Range("c5").End(xlToRight).Column Step 2
    
36.        r = Cells(7, i).End(xlDown).Row
    
37.        Set 区域 = Range(Cells(7, i), Cells(r, i))
    
38.           For Each rng In 区域
    
39.               If rng = rng.Offset(0, 1) Then
    
40.               rng.Interior.ColorIndex = 3
    
41.               End If
    
42.           Next
    
43.      Next
    
44.      With [c7:v33]
    
45.         .Borders.LineStyle = 1
    
46.         .Font.Name = "宋体"
    
47.         .Font.Size = 12
    
48.         .HorizontalAlignment = xlCenter
    
49.         .VerticalAlignment = xlCenter
    
50.      End With
    
51. End Sub

复制代码

粗略弄了一下，每个科目的最后一场给你设了空白，用来手动调节，没考虑同一考场的两人为一人情况，应该也好处理用for each 隔列比对判断即可,r,如果有这种情况，已经图红。我也是才接触VBA，凑合着用吧。看看哪个大师给优化一下，见笑了。

wdjwdjwdj0101

全党 发表于 2023-2-20 23:58
粗略弄了一下，每个科目的最后一场给你设了空白，用来手动调节，没考虑同一考场的两人为一人情况，应该也好 ...

全党

wdjwdjwdj0101 发表于 2023-2-21 08:30

上次，规避筛选有问题，已修正，可重新下载附件

wdjwdjwdj0101

全党 发表于 2023-2-21 22:59
上次，规避筛选有问题，已修正，可重新下载附件

同一考场的多个位置为一人情况

全党

wdjwdjwdj0101 发表于 2023-2-22 09:46
同一考场的多个位置为一人情况

试一下，有点慢