2024年4月27日发(作者：)
精品
用vba统计分析学生成绩（三率）
根据全校（年级）学生成绩汇总表，按年级分班级对各学科参考人数、总分、平均分、及格人数、
及格率、良好人数、良好率、优秀人数、优秀率及教师积分进行统计分析。
代码：
﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍
Sub 统计参数()
Updating = False '屏蔽刷屏
yAlerts = False '禁止弹出提示
Dim Arr, brr(), d As Object, i As Long, j As Long, k As Long, m As Long, s As Long, t As
Long, Endrow As Long, EndColumn As Long
感谢下载载
精品
Set d = CreateObject("nary") '用代码创建字典
Sheets("成绩分析").Delete
On Error GoTo 0
With Sheets("原始数据")
Endrow = .Cells(, 1).End(3).Row - 1 'A列最大单元格减1,即获取行数
EndColumn = .Cells(2, ).End(1).Column '获取列数
Arr = .Cells(2, 1).Resize(Endrow, EndColumn).Value '把"原始数据"表从Cells(2, 1)
到最后一个单元格的数值装入arr
End With
ReDim brr(1 To UBound(Arr), 1 To 12) '重新声明brr,行从1到最后1行，列从1到12
For j = 5 To UBound(Arr, 2) 'j从第5列到最后一列（从第二行读取列数）
For i = 2 To UBound(Arr) 'i从第2行到最后一行
If Len(Arr(i, j)) Then '当(Arr(i, j)不为空时
s = d(Arr(1, j) & Arr(i, 1) & Arr(i, 3)) 'd() 标题（学科） 年级 班别
If s = Empty Then
m = m + 1
d(Arr(1, j) & Arr(i, 1) & Arr(i, 3)) = m
s = m
brr(s, 1) = Arr(i, 1) '把各年级装入数组brr(s, 1)
brr(s, 2) = Arr(i, 3) '把各班别装入数组brr(s, 1)
brr(s, 3) = Arr(1, j) '把各科目装入数组brr(s, 1)
End If
brr(s, 4) = brr(s, 4) + 1 'brr(s, 4)计数
brr(s, 5) = brr(s, 5) + Arr(i, j) 'brr(s, 5)累加成绩
brr(s, 6) = Format(brr(s, 5) / brr(s, 4), "0.00") 'brr(s, 5)装入平均成绩
'明确各科部分，以便计算出其 “三率”
If Arr(1, j) = "语文" Or Arr(1, j) = "数学" Or Arr(1, j) = "英语" Then k = 120
'如果所在列为语文 Or数学or英语则总分 k = 120分.
If Arr(1, j) = "物理" Or Arr(1, j) = "化学" Then k = 100
'如果所在列为"物理" Or"化学"则 ' 总分 k = 100分.
If Arr(1, j) = "政治" Or Arr(1, j) = "历史" Or Arr(1, j) = "生物" Then k = 60
'如果所在列为"政治" Or "历史" Or "生物"则总分 k = 60分.
If Arr(i, j) >= 0.6 * k Then brr(s, 7) = brr(s, 7) + 1
'统计及格人数，存入brr(s, 7)
If Arr(i, j) >= 0.8 * k Then brr(s, 9) = brr(s, 9) + 1
'统计良好人数，存入brr(s, 9)
If Arr(i, j) >= 0.9 * k Then brr(s, 11) = brr(s, 11) + 1
感谢下载载
精品
'统计优秀人数，存入brr(s, 11)
brr(s, 8) = Format(brr(s, 7) / brr(s, 4), "0.00%")
' 计算及格率，格式为%，存入brr(s, 8)
brr(s, 10) = Format(brr(s, 9) / brr(s, 4), "0.00%")
' 计算良好率，格式为%，存入brr(s,10)
brr(s, 12) = Format(brr(s, 11) / brr(s, 4), "0.00%")
' 计算优秀率，格式为%，存入brr(s, 12)
End If
Next
Next
With (After:=Sheets())
.Name = "成绩分析" '新建工作表，并命名为"成绩分析"
End With
With Sheets("成绩分析")
.Cells(3, 1).Resize(1000, 14).ClearContents '清除指定区域
.Cells(3, 1).Resize(1000, 14).UnMerge '清除合并，即将一个合并区域分成
多个单元格
.Cells(4, 1).Resize(m, 14).Value = brr '把brr数组填入Cells(4, 1).Resize(m,
14)
.Cells(3, 1).Resize(1, 14).Value = Array("年级", "班级", "学科", "参考人数", "总分", "平
均分", "及格人数", "及格率", "良好人数", "良好率", "优秀人数", "优秀率", "积分", "任课老师") '标题
填入Cells(3, 1).Resize(1, 14)
With .Cells(3, 1).Resize(m + 1, 14) '在整个数据区域
.Sort key1:=.Cells(4, 1), order1:=xlAscending, key2:=.Cells(4, 2),
order2:=xlAscending, Header:=xlYes
'单元格区域.Sort关键字1:=单元格区域("A4"),
.yle = xlNone '取消边框
.yle = xlContinuous '区域内单元格的边框线为实线
End With
With .Cells(4, 1).Resize(m, 1) '选定操作范围，B4至Bm。
.Offset(0, 1). '在当前单元格Cells(4, 1)（下同）右侧处
插入一列
For i = 1 To .Count - 1
If .Cells(i).Value = .Cells(i + 1).Value Then .Cells(i).Offset(0,
1).Resize(2, 1).Merge '上下单元格相等，右侧相应的合并。
Next
.Offset(0, 1).Copy '复制当前单元格右列第4至第m个单
感谢下载载
精品
元格
.PasteSpecial xlPasteFormats '粘贴复制的源格式
.Offset(0, 1). '删除右边第1列
End With
With .Cells(4, 2).Resize(m, 1) '当前单元格为Cells(4, 2)
.Offset(0, 1).
For i = 1 To .Count - 1
If .Cells(i).Value = .Cells(i + 1).Value Then .Cells(i).Offset(0,
1).Resize(2, 1).Merge '上下单元格相等，右侧相应的合并
Next
.Offset(0, 1).Copy '复制当前单元格右列第4至第m个单元格
.PasteSpecial xlPasteFormats '粘贴复制的源格式
.Offset(0, 1). '删除右边第1列
End With
.Cells(1, 1).Select
End With
With Sheets("成绩分析")
t = Range("b65536").End(xlUp).Row '所要计算的行数
For i = 4 To t
.Cells(i, 13) = Format(.Cells(i, 6) + .Cells(i, 8) * 100 + .Cells(i, 10) * 100
+ .Cells(i, 12) * 100, "0.00") '计算积分
Next
End With
Updating = True
Set d = Nothing
Erase brr: Erase Arr
End Sub
﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍
感谢下载载
精品
感谢下载!
欢迎您的下载，资料仅供参考
感谢下载载
发布评论