快速浏览
往期合集:【
2023年3月】【
2023年4月】【
2023年5月】【
2023年6月】【
2023年7月】
实用案例|收费管理系统|
中医诊所收费系统||日期控件|简单的收发存||电子发票管理助手|Excel表格拆分神器||Excel多种类型文件合并|电子发票登记系统(Access版)|收费使用项目|
财务管理系统|内容提要
考场安排
问题展开,考生顺序打乱
大家好,我是冷水泡茶,今天在论坛上看到一个求助贴:
他的明细表“考试”是这样的,有几百条数据,需要重新写入数据的列有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 Sub
Function 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---
喜欢就点个赞、点在看、留个言呗!分享一下更给力!感谢!
需要示例文件的朋友请稍微留意一下:
写文不易,分享免费,请关注、点赞、点在看、点广告、留言,如果不愿走上面的“流程”,打赏也行,万分感谢!