本文于2023年8月11日首发于本人同名其他平台，更多文章案例请搜索关注！
内容提要
考场安排
问题展开，考生顺序打乱
大家好，我是冷水泡茶，今天在论坛上看到一个求助贴：
他的明细表“考试”是这样的，有几百条数据，需要重新写入数据的列有B列考场、F列考场地点、G列座位号、H列考号：
还有一张考场安排表，列出每一个考场可容纳的最大考试人数，有近30个考场：
他的需求就是：把每个学生安排到各个考场去，因为每个班级参加考试的人数，考场都会经常发生变化，如何能快速安排考场？我们可以考虑用VBA来完成。
我们一起来看一看吧：
基本思路
1、把所有考场的桌子排成一行，正常情况下应大于等于所有考生的人数。
2、所有考生也排成一行，他的“考试”表已经这样做了，依次入座。
3、主要方法是采用数组。
程序代码
1、就一个过程“ExamRoom“：
Sub ExamRoom() Dim ws As Worksheet Dim lastRow As Integer, iCol As Integer Dim iRow As Integer Dim arrData() Dim arrTem() Set ws = Sheets("考场安排") ws.Activate lastRow = ws.UsedRange.Rows.Count iCol = 3 arrData = ws.Range(Cells(2, 1), Cells(lastRow, iCol)).Value iRow = UBound(arrData, 1) k = 1 For i = 1 To iRow For j = 1 To arrData(i, 3) ReDim Preserve arrTem(1 To 4, 1 To k) arrTem(1, k) = arrData(i, 1) arrTem(2, k) = arrData(i, 2) arrTem(3, k) = j arrTem(4, k) = Format(i, "00") & Format(j, "00") k = k + 1 Next Next Dim arrCol(), arrResult() Set ws = Sheets("考试") ws.Activate arrCol = Array(2, 6, 7, 8) For i = LBound(arrCol) To UBound(arrCol) lastRow = ws.UsedRange.Rows.Count - 1 ReDim arrResult(1 To UBound(arrTem, 2)) For j = 1 To UBound(arrTem, 2) arrResult(j) = arrTem(i + 1, j) Next ws.Cells(2, arrCol(i)).Resize(lastRow, 1).ClearContents ws.Cells(2, arrCol(i)).Resize(lastRow, 1).NumberFormat = "@" lastRow = Application.WorksheetFunction.Min(lastRow, UBound(arrTem, 2)) ws.Cells(2, arrCol(i)).Resize(lastRow, 1) = Application.WorksheetFunction.Transpose(arrResult) NextEnd Sub
代码解析：
（1）把“考场安排”表数据读入数组arrData()。
（2）通过两层循环，把考场座位排成一行写入数组arrTem。外层循环每个考场，内层循环每个考场的座位数。
（3）定义一个数组arrCol，元素为明细表“考试”需要填入数据的列。
（4）再通过两层循环，逐列对应写入数据到明细表“考试”。
题外话
1、在那个贴子中，有位高人的方法我看了一下，比我的要好，他是把“考试“表数据读入数组，然后直接在这个数组中写入数据，然后一次性写入“考试”表，而不像我重新定义另一个数组，确实高，不得不佩服。
2、另外，试想一下，如果我是学校里安排考场的那个人，我会怎么做呢？
（1）就目前这个“考试”表，我可能会把跟考场相关的字段放到一起，而不是像现在这样混杂在一起，起码可以方便地把考场安排数据一次写入。调整如下：
（2）楼主给出的原始文件中，“考试”表中各个班级是混杂排序的，就是已经打乱了，把考场按顺序对应就算成功了。但是，当我们从最开始安排考场的时候，每个班级应该是都排在一起的，我们必须把它给打乱或者是把考场顺序打乱，否则每个班的考生大多安排在一个考场，那就不合适了。那么，如何打乱考生或考场的顺序呢？方法有三：
（a）方法1：辅助列+随机数法
在I列输入公式=rand()，生成0-1的随机数，我们把整个表格按照I列排序，然后再按排考场。
（b）方法2：VBA代码法：
把B列到D列数据读入数组，然后设法对它进行乱序，我让ChatGPT给我写了一个自定义函数，把数组乱序排列，然后再回写到工作表。
Public orderType As StringSub randomOrder() Dim ws As Worksheet Dim lastRow As Integer Dim arrData() Set ws = Sheets("考试") Dim rng As Range With ws lastRow = .UsedRange.Rows.Count If orderType = "考生" Then Set rng = .Range("B2:D" & lastRow) Else Set rng = .Range("E2:H" & lastRow) End If arrData = rng.Value arrData = ShuffleArray(arrData) rng = arrData End WithEnd SubFunction ShuffleArray(arr As Variant) As Variant Dim numRows As Long Dim randomArr() As Variant Dim shuffledArr() As Variant Dim i As Long, j As Long Dim tempRow As Long ' 获取数组的行数 numRows = UBound(arr, 1) - LBound(arr, 1) + 1 ' 创建一个与原始数组相同维度的新数组 ReDim randomArr(1 To numRows, 1 To 2) ReDim shuffledArr(LBound(arr, 1) To UBound(arr, 1), _ LBound(arr, 2) To UBound(arr, 2)) ' 填充随机数列 For i = 1 To numRows randomArr(i, 1) = i + LBound(arr, 1) - 1 ' 原始行号 randomArr(i, 2) = Rnd() ' 随机数 Next i ' 按照随机数列的第二列排序 For i = 1 To numRows - 1 For j = i + 1 To numRows If randomArr(i, 2) > randomArr(j, 2) Then ' 交换两行的数据 tempRow = randomArr(i, 1) randomArr(i, 1) = randomArr(j, 1) randomArr(j, 1) = tempRow ' 交换随机数 tempRow = randomArr(i, 2) randomArr(i, 2) = randomArr(j, 2) randomArr(j, 2) = tempRow End If Next j Next i ' 根据排序后的行号复制原始数组到新数组 For i = LBound(arr, 1) To UBound(arr, 1) For j = LBound(arr, 2) To UBound(arr, 2) shuffledArr(i, j) = arr(randomArr(i - LBound(arr, 1) + 1, 1), j) Next j Next i ' 返回打乱顺序后的新数组 ShuffleArray = shuffledArrEnd Function
代码解析：
定义一个公共变量orderType，用来判断是考生打乱还是考场打乱。
根据点击的命令按钮，给orderType赋值“考生”或“考场”，然后调用randomOrder过程，对“考试”表中不同的区域进行乱序排序，不满意可以多点几次。
（c）方法3：先按班级排序，然后按排考场，然后把E~H列单独按“座位号”排序。相当于，我把第一个班级先安排到不同的考场坐1号桌，安排不下的，就坐2号桌，不够安排的，下一个班级顶上......
最后，可以手工按“班级”或“考场”进行排序，可以分别展示某个班的考生在哪个考场，或者某个考场都有哪些班级的考生。
---End---
喜欢就点个赞、点在看、留个言呗！分享一下更给力！感谢！