excel vba计算优秀率：Excel，VBA

本文于2023年8月25日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！

内容提要

• 班级学生按成绩分组，人数、平均分尽量接近

大家好，我是冷水泡茶，昨天发了一篇文章【Excel VBA 班级学生按成绩分组，使得平均分接近】，这是EXCELHOME论坛上的网友求助贴，他并没有说明结果如何输出，当时也就没有考虑分组输出的问题，加之赶着要在24点之前当天发文，初步完成就发出来了。

当时考虑的方法是，按成绩排序，再按1、2、3、3、2、1、1、2、3......这样的形式给每个同学标上分组号码。

这种方法勉强可行，如果正向、反向都能全部选到，即总人数正好是分组数的2倍，这样的方法应该是没有问题的。如果不是这样，结果可能就有点偏差。当时也有这样的考虑：最高分应该与最低分搭配，这样应该最接******均分。但是，当时也没能考虑清楚，加之为了赶在当天发文，来不及细想，就这样“交差”了。果然，这样“糊弄”是不行的，有人在文章下面留言：

他没再回复，我就按照我自己的思路，对代码进行了优化，并且对输出格式进行了调整，由于改动还是比较大的，决定重发一篇（主要是没时候再写别的内容了）我们一起来看看吧：

基本思路

1、分组方法问题，我们先从头选到中间位置，余下的再从末尾开始向前选，这样能确保最高分和最低分在一个组里。

2、输出格式问题，如我昨天所说，按列输出，即把每一组并列排列。

程序代码

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() Dim arrTem() Dim midNum As Integer, iRow As Integer Dim totalPoints As Double, averagePoints As Double Set ws = ThisWorkbook.Sheets("Sheet1") ws.Activate lastRow = ws.UsedRange.Rows.Count For i = lastRow To 2 Step -1 If Cells(i, 2) = "" Then Rows(i).Delete Else totalPoints = totalPoints Cells(i, 3) End If Next lastRow = ws.UsedRange.Rows.Count lastCol = 4 arrData = ws.Range(Cells(2, 1), Cells(lastRow, lastCol)).Value ReDimarrSequence(1ToNum) For i = 1 To Num j = Num - i 1 arrSequence(i) = j Next '先分一半 k = 0 arrData = SortArray(arrData, True, False, 3) midNum = Int(UBound(arrData) / 2) midNum = midNum - midNum Mod NumFori=1TomidNum 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 '再分一半,把最高分搭一个最低分 k = 0 lastRow = UBound(arrData) For i = lastRow To midNum 1 Step -1 m = lastRow - i 1 If (m - 1) Mod Num 1 = 1 Then k = k 1 End If If k Mod 2 = 0 Then arrData(i, 4) = arrSequence((m - 1) Mod Num 1) Else arrData(i, 4) = (m - 1) Mod Num 1 End If Next' Sheets("TEM").Range("A2").Resize(Sheets("TEM").UsedRange.Rows.Count, Sheets("TEM").UsedRange.Columns.Count).Clear' Sheets("TEM").Range("A2").Resize(UBound(arrData, 1), UBound(arrData, 2)) = arrData arrData = SortArray(arrData, , False, 3) iRow = Application.WorksheetFunction.RoundUp(lastRow / Num, 0) 4 ReDim arrTem(1 To iRow, 1 To Num * 3) For j = 1 To Num k = 0 For i = 1 To lastRow If arrData(i, 4) = j Then k = k 1 For p = 1 To 3 arrTem(k 4, p (j - 1) * 3) = arrData(i, p) arrTem(4, p (j - 1) * 3) = j Next arrTem(1, 3 (j - 1) * 3) = arrTem(1, 3 (j - 1) * 3) arrData(i, 3) arrTem(2, 3 (j - 1) * 3) = k arrTem(3, 3 (j - 1) * 3) = arrTem(1, 3 (j - 1) * 3) / k End If Next Next With Sheets("分组") .Activate .Cells.Clear .Range("C1").Resize(UBound(arrTem), UBound(arrTem, 2)) = arrTem .Range("A1").Select .Range("A1") = "总分" .Range("A2") = "人数" .Range("A3") = "平均分" .Range("A4") = "分组" .Range("B1") = totalPoints .Range("B2") = lastRow .Range("B3") = totalPoints / lastRow Application.DisplayAlerts = False For i = 1 To Num With .Range(Cells(4, 3 (i - 1) * 3), Cells(4, 2 i * 3)) .Merge .HorizontalAlignment = xlCenter If i Mod 2 = 1 Then .Interior.Color = RGB(128, 128, 128) End If End With Next Application.DisplayAlerts = True End WithEnd Sub

‍代码解析：

（1）定义一些变量，工作表对象ws，数组，中间数，总分、平均分等。过程设置了一个参数，分组数。

（2）line11~20，循环Sheet1表行，把空白行删除（如果有），顺便计算总分。

（3）line21~23，把数据装入数组。

（4）line24~28，把数组arrSequence的值写成从分组数到1的倒序的数字序列。

（5）line31，利用自定义函数SortArray对数组按第3列进行行降序排序。

（5）line32~33，计算一个中间数，减去这个数除以分组数的余数，即使得这个数正好能被分组数整除，也就是说正好够选满一轮。

（6）line34~43，循环数组到中间位置，对行号除以分组数求余，当它等于1时，表示是新一轮分组开始，k 1。接着判断k除以2求余，如果等于0,表明是偶数轮，我们就把原来序列号是1~num的，给它倒过来。使得分组更均匀，平均分更接近。

（7）line45~57，从数组最大行向前循环，写入分组号码。

（8）line58~59，注释掉的两行代码，原来的作用是把未处理的数据写入“TEM”表，可以查看运行的结果。可以删除掉。

（9）line60，对数据按总分列进行降序排列。

（10）line61~77，把分组数据以分组号为表头并列排列，计算分组总分、人数、平均分。

（11）line78~101，把数组写入工作表“分组”，分组表头合并居中，隔列标色。

2、其他过程：CmdGroup，分组命令按钮，SortArray，数组排序自定义函

数：

Private Sub CmdGroup_Click() Dim Num As Integer, inputNum As String inputNum = inputbox("请输入分组数:", , 3) If Not IsNumeric(inputNum) Then Exit Sub 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写的代码，可以将数组按行、列，对指定的列、行进行升、降序排序。

Tips

1、InputBox输入数据，其结果是字符串，如果点取消，则是一个空字符串。如果我们要输入数字，要把它转换成数值类型。

2、工作表取得数据区域最大行号，UsedRange.Rows.Count

3、工作表数据装入数组的方法，有很多种。

4、工作表删除空行的方法，从最大行号向前删除。

5、数组排序的方法。

......

~~~~~~End~~~~~~

喜欢就点个赞、点在看、留个言呗！分享一下更给力！感谢！