用vba统计分析学生成绩（三率）

用vba统计分析学生成绩（三率）

根据全校（年级）学生成绩汇总表，按年级分班级对各学科参考人数、总分、平均分、及格人数、及格率、良好人数、良好率、优秀人数、优秀率及教师积分进行统计分析。

代码：

﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍

Sub 统计参数()

Application.ScreenUpdating = False '屏蔽刷屏

Application.DisplayAlerts = 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(\用代码创建字典 Sheets(\成绩分析\ On Error GoTo 0

With Sheets(\原始数据\

Endrow = .Cells(Rows.Count, 1).End(3).Row - 1 'A列最大单元格减1,即获取行数 EndColumn = .Cells(2, Columns.Count).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)不为空时

1

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), \装入平均成绩

'明确各科部分，以便计算出其 “三率”

If Arr(1, j) = \语文\\数学\英语\'如果所在列为语文 Or数学or英语则总分 k = 120分.

If Arr(1, j) = \物理\化学\'如果所在列为\物理\化学\则 ' 总分 k = 100分.

If Arr(1, j) = \政治\历史\生物\ '如果所在列为\政治\历史\生物\则总分 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), \' 计算及格率，格式为%，存入brr(s, 8)

brr(s, 10) = Format(brr(s, 9) / brr(s, 4), \' 计算良好率，格式为%，存入brr(s,10)

brr(s, 12) = Format(brr(s, 11) / brr(s, 4), \' 计算优秀率，格式为%，存入brr(s, 12) End If Next Next

With Sheets.Add(After:=Sheets(Sheets.Count))

.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

2

'单元格区域.Sort关键字1:=单元格区域(\ .Borders.LineStyle = xlNone '取消边框

.Borders.LineStyle = xlContinuous '区域内单元格的边框线为实线 End With

With .Cells(4, 1).Resize(m, 1) '选定操作范围，B4至Bm。

.Offset(0, 1).EntireColumn.Insert '在当前单元格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).EntireColumn.Delete '删除右边第1列 End With

With .Cells(4, 2).Resize(m, 1) '当前单元格为Cells(4, 2) .Offset(0, 1).EntireColumn.Insert 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).EntireColumn.Delete '删除右边第1列 End With

.Cells(1, 1).Select End With

With Sheets(\成绩分析\

t = Range(\所要计算的行数 For i = 4 To t

.Cells(i, 13) = Format(.Cells(i, 6) + .Cells(i, 8) * 100 + .Cells(i, 10) * 100 + .Cells(i, 12) * 100, \计算积分

Next

End With

Application.ScreenUpdating = True Set d = Nothing

Erase brr: Erase Arr End Sub

﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍﹍

3

本文来源：https://www.bwwdw.com/article/y5ad.html