说明：这是本人刚开始学VBA的时候为学校做的学生成绩统计模板，在末用VBA以前，每次学校考试的成绩统计都是用公式重复操作，非常麻烦，耗时长而且很容易出错，用VBA程序做的成绩统计不仅快而且非常准确，现在把它公布出来，与大家分享。
内容包括计算总分、统计三率、统计语数外三科总和、按年级及班级排名次、生成年级报表、排考场等等。
Option Explicit
Sub 成绩统计()
'**************************************************变量声明部分**************************************************
Dim i As Integer, j As Integer, k As Integer '定义循环变量
Dim MFBZ As Integer, ZF As Integer, SZ As Integer '满分标准、总分变量、三总变量
Dim Ddbj As Integer, MC As Integer, Dkf As Integer '断点标记、年级名次、单科分总和
Dim PJF, JGL, LHL, YXL '三率变量
Dim QK As Integer, JGRS As Integer, LHRS As Integer, YXRS As Integer '缺考、及格、良好、优秀人数
Dim BJS As Integer, BJRS As Integer '班级数、班级人数
Dim YBendrow As Integer, TJBendrow As Integer, BBendrow As Integer '各工作表最大行数
Dim endcol As Integer, Shtcount As Integer '各工作表最大列数及工作表总数
Dim YB As String, TJB As String, BB As String, S As Variant '定义工作表名变量
Dim StateTime As Single, EndTime As Single '程序开始、结束时间
Dim M As String '考试次数
'***********************************************************************************************************
On Error Resume Next '错误处理
Application.ScreenUpdating = False '关闭屏幕刷新
'M = InputBox("这是本学期第几次考试：")
YB = InputBox("请输入您要进行统计的工作表名：") '取得所要操作的工作表名
If YB = "" Then
Exit Sub
End If
Shtcount = ActiveWorkbook.Sheets.Count '当前工作薄中的工作表总数
Sheets(YB).Select '选定工作表
TJB = YB & "统计"
BB = YB & "报表"
StateTime = Timer '开始时间
'*****************删除旧工作表*****************
Application.DisplayAlerts = False '屏蔽删除对话框
For Each S In Sheets '删除旧表，准备统计
If S.Name = TJB Or S.Name = BB Then
S.Delete
End If
Next S
Application.DisplayAlerts = True '打开对话框显示
YBendrow = ActiveSheet.Range("c65536").End(xlUp).Row '当前工作表最大行数
Range(Cells(3, 15), Cells(YBendrow, 19)).ClearContents '删除以前统计结果，为新的统计做准备
'*****************计算总分*****************
For i = 3 To YBendrow '行循环
ZF = 0
For j = 6 To 14 '列循环
If Cells(i, j).Value <> "" And Cells(i, j).Value <> -1 Then
ZF = ZF + Cells(i, j).Value
End If
Next j
Cells(i, 15).Value = ZF
Next i
'*****************计算三总*****************
For i = 3 To YBendrow
SZ = 0
For j = 7 To 9
If Not Cells(i, j) = "" And Not Cells(i, j) = -1 Then
SZ = SZ + Cells(i, j)
End If
Next j
Cells(i, 18) = SZ
Next i
'*****************排年级名次*****************
For i = 3 To YBendrow
MC = Application.WorksheetFunction.Rank(Cells(i, 15), _
Range(Cells(3, 15), Cells(YBendrow, 15)), 0) '调用工作表函数计算当前总分在总分列的位次
Cells(i, 16).Value = MC '将位次填入相应的单元格
Next i
'*****************排班级名次*****************
Range("A2").CurrentRegion.Select '选定排序区域
Selection.Sort Key1:=Range("B3"), Order1:=xlAscending, Key2:=Range _
("O3"), Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase _
:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
xlSortNormal, DataOption2:=xlSortNormal '按班级升序和总分降序自动排序
BJS = Application.WorksheetFunction.Max(Range(Cells(3, 2), Cells(YBendrow, 2))) '计算班级数
For i = 3 To YBendrow '开始循环
If Cells(i, 2).Value <> Cells(i - 1, 2) Then '设置转换班级时的标记点
Ddbj = Cells(i - 1, 2).Row '当班级改变时，定义一个行变量（标记点）
End If
If Cells(i, 2) = Cells(i - 1, 2) Then
If Cells(i, 15) <> Cells(i - 1, 15) Then
Cells(i, 17) = i - Ddbj '行号减标记点即为名次
Else
Cells(i, 17) = Cells(i - 1, 17) '如果当前总分等于上一个总分，则名次相同
End If
Else
Cells(i, 17) = 1 '各班第一个人的名次为1
End If
Next i
'*****************排三总名次*****************
For i = 3 To YBendrow '开始循环
MC = Application.WorksheetFunction.Rank(Cells(i, 18), Range(Cells(3, 18), Cells(YBendrow, 18)), 0) '调用工作表函数
Cells(i, 19).Value = MC
Next i
'**********************************统计三率**********************************
Sheets.Add after:=Worksheets(YB)
ActiveSheet.Name = TJB
Worksheets(TJB).Select
'设计表头
Cells(2, 1) = "班级"
Cells(2, 2) = "项目"
Cells(2, 3) = "政治"
Cells(2, 4) = "语文"
Cells(2, 5) = "数学"
Cells(2, 6) = "英语"
Cells(2, 7) = "物理"
Cells(2, 8) = "化学"
Cells(2, 9) = "生物"
Cells(2, 10) = "历史"
Cells(2, 11) = "地理"
Range("a1:k1").Merge
Range("a1").FormulaR1C1 = YB & "成绩(三率)统计表"
Range("A1").Font.Size = 22
endcol = Range("A2").End(xlToRight).Column
For j = 1 To BJS '行循环
Cells(j + 2, 1) = j
Cells(j + 2, 2) = "平均分"
Cells(j + BJS + 2, 1) = j
Cells(j + BJS + 2, 2) = "及格率(%)"
Cells(j + BJS * 2 + 2, 1) = j
Cells(j + BJS * 2 + 2, 2) = "良好率(%)"
Cells(j + BJS * 3 + 2, 1) = j
Cells(j + BJS * 3 + 2, 2) = "优秀率(%)"
For k = 3 To endcol '列循环
If k = 3 Then '判断总分
MFBZ = 100
ElseIf k < 7 Then
MFBZ = 150
Else
MFBZ = 100
End If
Worksheets(YB).Select '对源表进行统计
QK = 0 '设置初始值
BJRS = 0
Dkf = 0
JGRS = 0
LHRS = 0
YXRS = 0
For i = 3 To YBendrow '行循环
If Cells(i, 2) = j Then
BJRS = BJRS + 1
If Cells(i, k + 3) = -1 Then '统计缺考人数
QK = QK + 1
Else
Dkf = Dkf + Cells(i, k + 3) '计算班级单科总分
End If
If Cells(i, k + 3) >= MFBZ * 0.6 Then '及格人数统计
JGRS = JGRS + 1
End If
If Cells(i, k + 3) >= MFBZ * 0.7 Then '良好人数统计
LHRS = LHRS + 1
End If
If Cells(i, k + 3) >= MFBZ * 0.85 Then '优秀人数统计
YXRS = YXRS + 1
End If
End If
Next i
If BJRS = 0 Or Dkf = 0 Then '筛选空班级
PJF = ""
JGL = ""
LHL = ""
YXL = ""
Else
PJF = Dkf / (BJRS - QK) '计算三率
JGL = JGRS / (BJRS - QK) * 100
LHL = LHRS / (BJRS - QK) * 100
YXL = YXRS / (BJRS - QK) * 100
End If
Worksheets(TJB).Select '填入目标表相应位置
If BJRS = 0 Or Dkf = 0 Then
Cells(j + 2, k) = ""
Cells(j + BJS + 2, k) = ""
Cells(j + BJS * 2 + 2, k) = ""
Cells(j + BJS * 3 + 2, k) = ""
Else
Cells(j + 2, k) = PJF
Cells(j + 2, k).NumberFormatLocal = "0.00" '设置结果显示格式(保留两位小数)
Cells(j + BJS + 2, k) = JGL
Cells(j + BJS + 2, k).NumberFormatLocal = "0.00"
Cells(j + BJS * 2 + 2, k) = LHL
Cells(j + BJS * 2 + 2, k).NumberFormatLocal = "0.00"
Cells(j + BJS * 3 + 2, k) = YXL
Cells(j + BJS * 3 + 2, k).NumberFormatLocal = "0.00"
End If
Next k
Next j
'删除空班级行
Worksheets(TJB).Select
TJBendrow = Range("A65536").End(xlUp).Row
For i = TJBendrow To 3 Step -1
If Cells(i, 4).Value = "" Then
Cells(i, 4).EntireRow.Delete
End If
Next i
'设置“统计”表的格式
Range("A3").Select
ActiveWindow.FreezePanes = True '冻结窗格
Cells.HorizontalAlignment = xlCenter '居中对齐
Columns("A:A").ColumnWidth = 3.5 '列宽
Columns("B:B").ColumnWidth = 8.38 '列宽
Columns("C:E").ColumnWidth = 6.88 '列宽
Columns("F:K").ColumnWidth = 5.63 '列宽
'选中全部单元格，将单元格内部图案改为白色
Cells.Select
With Selection.Interior
.ColorIndex = 2
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
'设置数据区域外边框为粗线，内部为细线
TJBendrow = Range("a65536").End(xlUp).Row
Range(Cells(2, 1), Cells(TJBendrow, endcol)).Select
Call 设置边框 '调用“设置边框”子过程
Cells(1, 1).Select
'********************生成年级报表*********************
Sheets.Add after:=Worksheets(TJB)
ActiveSheet.Name = BB
Worksheets(YB).Select
Range("a2").CurrentRegion.Copy
Worksheets(BB).Select
Range("a2").PasteSpecial
Columns("d:e").Delete shift:=xlToLeft
Columns("a:a").Delete shift:=xlToLeft
BBendrow = Range("a65536").End(xlUp).Row + 1
Worksheets(TJB).Select
endcol = Cells(2, 256).End(xlToLeft).Column
TJBendrow = Cells(2, 1).End(xlDown).Row
Range(Cells(3, 1), Cells(TJBendrow, endcol)).Copy Worksheets(BB).Cells(BBendrow, 1) '将统计表中的数据拷到报表中
Worksheets(BB).Select
Range("A3").Select
ActiveWindow.FreezePanes = True '冻结窗格
Cells.HorizontalAlignment = xlCenter '居中对齐
Columns("A:A").ColumnWidth = 3.5 '设置列宽
Columns("B:B").ColumnWidth = 8.38
Columns("C:K").ColumnWidth = 6.88
Columns("L:L").ColumnWidth = 3.5
Columns("M:N").ColumnWidth = 4.63
Columns("O:O").ColumnWidth = 3.5
Columns("P:P").ColumnWidth = 4.88
Cells.Select '选中全部单元格，将单元格内部图案改为白色
With Selection.Interior
.ColorIndex = 2
.Pattern = xlSolid '设置内部图案
.PatternColorIndex = xlAutomatic '内部颜色设为自动
End With
BBendrow = Range("A65536").End(xlUp).Row
endcol = Range("IV2").End(xlToLeft).Column
Range(Cells(2, 1), Cells(BBendrow, endcol)).Select
Selection.Sort Key1:=Cells(3, 13), Order1:=xlAscending, Header:=xlGuess, _
MatchCase:=False '对报表按总名次升序排列
Range("A1:P1").Merge '合并单元格
Range("A1").Font.Size = 22
Range("A1").NumberFormatLocal = Left(YB, 2) & "##" & "班期末调研考试成绩报表"
ActiveSheet.Spinners.Add(2.25, 1.5, 18.75, 24).Select '添加微调项，控制表头显示格式
With Selection
.Value = 0
.Min = 0
.Max = 10
.SmallChange = 1
.LinkedCell = "$A$1"
.Display3DShading = True
.Placement = xlMoveAndSize
.PrintObject = False
End With
BBendrow = Range("a65536").End(xlUp).Row
endcol = Range("IV2").End(xlToLeft).Column
Range(Cells(2, 1), Cells(BBendrow, endcol)).Select
Call 设置边框 '调用“设置边框”子过程
For k = 11 To 3 Step -1 '删除空列
If Cells(3, k) = "" Then
Cells(3, k).EntireColumn.Delete
End If
Next k
'***********************************************************************************************************
'恢复统计前顺序
Sheets(YB).Select
Range("a2").CurrentRegion.Select
Selection.Sort Key1:=Range("D3"), Order1:=xlAscending, Key2:=Range _
("E3"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase _
:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
xlSortNormal, DataOption2:=xlSortNormal '按考场升序和座号升序排序
Cells(1, 1).Select
EndTime = Timer
MsgBox "运行程序共用时：" & EndTime - StateTime & "秒"
Application.ScreenUpdating = True
End Sub
Sub 编排考场()
Dim i As Integer, j As Integer, k As Integer, l As Integer
Dim M As String
Dim endrow1 As Integer, endrow2 As Integer
Sheets("考场编排").Select
endrow2 = Range("b65536").End(xlUp).Row
k = Application.WorksheetFunction.Sum(Range(Cells(2, 2), Cells(endrow2, 2)))
M = InputBox("请输入您准备编排考场的工作表名：")
If M = "" Then
Exit Sub
Else
Sheets(M).Select
End If
Range("A2").CurrentRegion.Select '选定排序区域
Selection.Sort Key1:=Range("O3"), Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase _
:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
xlSortNormal, DataOption2:=xlSortNormal '按总分降序自动排序
endrow1 = Range("c3").End(xlDown).Row
l = Application.WorksheetFunction.CountA(Range(Cells(3, 3), Cells(endrow1, 3)))
If l <> k Then
MsgBox "您的考场编排工作表未准备好!" & Chr(13) & Chr(10) & "请编排好后再运行此程序!"
Exit Sub
End If
Range(Cells(3, 4), Cells(endrow1, 5)).ClearContents
For i = 1 To endrow2 - 1
For j = 1 To Sheets("考场编排").Cells(i + 1, 2).Value
endrow1 = Range("e65536").End(xlUp).Row
Cells(endrow1 + 1, 4) = i
Cells(endrow1 + 1, 5) = j
Next j
Next i
End Sub
Sub 设置边框() '子过程
With Selection.Borders(xlEdgeLeft) '设置边框
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 3
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 3
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 3
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 3
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 3
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 3
End With
Cells.Select '选中全部单元格，将单元格内部图案改为白色
With Selection.Interior
.ColorIndex = 2
'.Pattern = xlSolid '设置内部图案
'.PatternColorIndex = xlAutomatic '内部颜色设为自动
End With
End Sub
Sub 删除工作表()
Dim i As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each i In Sheets
If i.Name <> "高一" Then
If i.Name <> "高二理科" Then
If i.Name <> "高二文科" Then
If i.Name <> "考场编排" Then
If i.Name <> "总分分布统计表" Then
i.Delete
End If
End If
End If
End If
End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
