VBA代码答疑? 100
程序如下图:
代码部分:
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
测试数据:
执行结果:
2024-04-10 广告