Question

VBA代码答疑？

输出结果：(麻烦使用VBA循环，因为还有其他模块要组合)A、单科成绩3人以下达标，通报名字和成绩；B、3人以上达标，列出人数和成绩区间即可；C、无人达标的科目无需列举；D、一个班级输出一条结果；

Answer 1

程序如下图：

代码部分：

Option Explicit

Sub 宏1()
Dim arr1 '数组1：原始数据
Dim arr2 '数组2：结果数据
Dim i
'！！！特别注意，下面两行获取数组范围的语句要求数据在单独的表，或者有空白分开，如果实际情况与帖子图不同需要修改！！！
arr1 = ActiveSheet.Range("a1").CurrentRegion
arr2 = ActiveSheet.Range("k4").CurrentRegion.Resize(, 2) 'K4下面的班级要事先列出，或者另外写循环获取
For i = 1 To UBound(arr2) '班级循环
arr2(i, 2) = 评价一个班(arr1, arr2(i, 1))
Next i
'保存结果
ActiveSheet.Range("k4").Resize(UBound(arr2), UBound(arr2, 2)) = arr2
End Sub

'评价一个班：arr1为原始数据，bj为班级名称
Function 评价一个班(arr1, bj) As String
Dim km(1 To 6) '单个科目的统计数据，1及格人数，2、3及格人员的最低分、最高分，4、5、6分别前三个及格人员的成绩和姓名
Dim i&, j&, k&, s$ '临时变量i、j、k，s为结果文本
For j = 3 To UBound(arr1, 2) '每个科目循环
'初始化中间变量
For k = 1 To UBound(km)
km(k) = Empty
Next k
km(2) = 999999
For i = 3 To UBound(arr1) '每个学生循环
If arr1(i, 1) = bj Or arr1(i, 1) & ":" = bj Then '只看 bj 班
If arr1(i, j) >= arr1(2, j) Then '及格
km(1) = km(1) + 1 '及格人数
If km(2) > arr1(i, j) Then km(2) = arr1(i, j) '最低分
If km(3) < arr1(i, j) Then km(3) = arr1(i, j) '最高分
If km(1) <= 3 Then '前三个
km(3 + km(1)) = arr1(i, 2) & "成绩" & arr1(i, j)
End If
End If
End If
Next i
Select Case km(1)
Case 0:
Case 1:     s = s & arr1(1, j) & "有1人达标，" & km(4) & "；"
Case 2:     s = s & arr1(1, j) & "有2人达标，" & km(4) & "、" & km(5) & "；"
Case 3:     s = s & arr1(1, j) & "有3人达标，" & km(4) & "、" & km(5) & "、" & km(6) & "；"
Case Else:  s = s & arr1(1, j) & "有" & km(1) & "人达标，成绩在" & km(2) & "-" & km(3) & "；"
End Select
Next j
评价一个班 = s
End Function

测试数据：

执行结果：

Answer 2

效果如下图：

代码如下图：