本文于2023年8月24日首发于本人同名其他平台，更多文章案例请搜索关注！
内容提要
班级学生按成绩分组，平均分接近
大家好，我是冷水泡茶，昨天在EXCELHOME论坛上看到一个坛友的求助贴：
他的数据表如下，要求分成3组，使得人数平均分接近：
咋一看，好象不太好搞，条件有点宽泛，再一想，好象通过排序，然后再按顺序把学生塞到一个个小组里不就成了？好象没什么问题，于是我就作了回复：
排序，分几组，就隔几人抽一个。打篮球，踢足球选队员有没有玩过？
今天又上论坛，看到这个问题好象还没有完美解决，既然他要VBA我们就用VBA来试一试吧，这简直不要太简单（高兴得有点早了）：
（唉，现在论坛审核得这么严了吗？我都发了几个小时了，回复还没通过。）
等我动手做的时候，很快做出了结果，每隔3人取一个，但突然想起，我们打篮球选队员的时候，并不是直接按顺序来选的，要么是每一轮都猜拳，谁赢了谁先选，要么第一轮先选，下一轮后选，以保证实力均衡。看来我的回复是有问题的，只好重新考虑分组方法，终于还是基本搞成功了，每轮颠倒抽取顺序，我们一起来看一看：
基本思路
1、首先， 把数据存入数组，我给他的数据前面加了一列“序号”，后面加了一列“分组”（本来是想直接在工作表中进行排序、分组操作的，加序号是保证数据顺序能恢复到原始排序状态。但后来还是在数组中操作了。）。
2、然后，把数组按照总分进行排序，升降序无所谓。
3、接着，根据分组的数量，在数组的第4列写入1、2、3、3、2、1这样的数字序列，代表各组的编号。
5、最后，把数组再次按照“分组“进行排序，并把结果写到一个工作表中。
程序代码
1、模块1，stuGrouping过程，学生分组：
Sub stuGrouping(Optional Num As Integer = 3) On Error Resume Next Dim ws As Worksheet Dim lastRow As Integer Dim lastCol As Integer Dim arrData() Dim arrSequence() Set ws = ThisWorkbook.Sheets("Sheet1") ws.Activate lastRow = ws.UsedRange.Rows.Count lastCol = 4 arrData = ws.Range(Cells(2, 1), Cells(lastRow, lastCol)).Value ReDim arrSequence(1 To Num) For i = 1 To Num j = Num - i + 1 arrSequence(i) = j Next arrData = SortArray(arrData, True, False, 3) lastRow = UBound(arrData) For i = 1 To lastRow If (i - 1) Mod Num + 1 = 1 Then k = k + 1 End If If k Mod 2 = 0 Then arrData(i, 4) = arrSequence((i - 1) Mod Num + 1) Else arrData(i, 4) = (i - 1) Mod Num + 1 End If Next arrData = SortArray(arrData, , , 4) With Sheets("TEM") .Activate .Cells.Clear .Range("A1:D1") = ws.Range("A1:D1").Value .Range("A2").Resize(UBound(arrData), UBound(arrData, 2)) = arrData .Range("A1").Select End WithEnd Sub
代码解析：
（1）定义一些变量，工作表对象ws，数组。过程设置了一个参数，分组数。
（2）line8~12，把Sheet1表原始数据读入数组。
（3）line13~17，把数组arrSequence的值写成从分组数到1的倒序的数字序列。
（4）line18，利用自定义函数SortArray对数组按第3列进行行降序排序。
（5）line20~29，循环数组，对行号除以分组数求余，当它等于1时，表示是新一轮分组开始，k+1。接着判断k除以2求余，如果等于0,表明是偶数轮，我们就把原来序列号是1~num的，给它倒过来。使得分组更均匀，平均分更接近。
（6）line30，这一行再次对数组按第4列分组进行排序，使得同一组的学生排列在一起。（也可以分成几列写到工作表）。如果要看出分组过程，可以把这句注释掉，我们就可以看到分组数据是像1、2、3、3、2、1、1、2、3......这样的形式排序的。
（7）把数组写入工作表“TEM”，就算完工。
2、其他过程：CmdGroup，分组命令按钮，SortArray，数组排序自定义函
数：
Private Sub CmdGroup_Click() Dim Num As Integer, inputNum As String inputNum = InputBox("请输入分组数:", , 3) Num = CInt(inputNum) Call stuGrouping(Num)End SubFunction SortArray(ByRef arr() As Variant, _ Optional sortByRow As Boolean = True, _ Optional ascending As Boolean = True, _ Optional sortByIndex As Long = 1) As Variant Dim numRows As Long Dim numCols As Long Dim i As Long, j As Long Dim temp As Variant numRows = UBound(arr, 1) numCols = UBound(arr, 2) If sortByRow Then ' 按行排序 For i = 1 To numRows - 1 For j = i + 1 To numRows If (arr(i, sortByIndex) > arr(j, sortByIndex) And _ ascending) Or (arr(i, sortByIndex) < arr(j, sortByIndex) And Not ascending) Then ' 交换行 For k = 1 To numCols temp = arr(i, k) arr(i, k) = arr(j, k) arr(j, k) = temp Next k End If Next j Next i Else ' 按列排序 For i = 1 To numCols - 1 For j = i + 1 To numCols If (arr(sortByIndex, i) > arr(sortByIndex, j) And _ ascending) Or (arr(sortByIndex, i) < arr(sortByIndex, j) And Not ascending) Then ' 交换列 For k = 1 To numRows temp = arr(k, i) arr(k, i) = arr(k, j) arr(k, j) = temp Next k End If Next j Next i End If SortArray = arrEnd Function
代码解析：
（1）CmdGroup，通过inputbox提示输入分组数，然后调用StuGrouping分组过程，以输入的数字为参数。
（2）SortArray这是参考AI写的代码，可以将数组按行、列，对指定的列、行进行升、降序排序。
~~~~~~End~~~~~~
喜欢就点个赞、点在看、留个言呗！分享一下更给力！感谢！