大学综合测评中，使用VBA代码自动完成EXCEL成绩表

更新：2014-04-18 下午

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

前言

我们在校大学生,每年都会评奖学金。而参考指标就是综合测评成绩。综合测评中，期末成绩又是最主要的部分。
一般每个大学教务系统都会生成一份原始成绩表，然后一级级下发到学习委员手中。而要计算出同学们的学业基本分，是要做很多EXCEL处理和计算工作的。
我担任过两年学习委员，这方面比较有经验，所以就写了一个宏，让成绩表的制作工作，基本由计算机程序直接完成。这样能大大提高效率。
本文主要目的：整理成果，方便日后维护、共享代码；留给我校，以后担任学习委员的学弟学妹，在制作综合测评成绩表时，可以使用我的程序增加效率；

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

代码

History: （代码修改历史记录列表）

1. Date:2013/10/6

Modification:部分注释错别字，解释错误的改动

2. Date:2013/10/10

Modification:科目名称超过15个字用8号字体

3. Date:2013/10/21

Modification:运行完后，弹出友情提示窗口

Sub 成绩表()
'Author:代号4101 首次发布:2013/10/6Dim 行范围, 列范围, 有效范围, 计数, i, j, title, 总学分, logo, str'去掉获得学分为0的行i = 4While Cells(i, 4) <> ""If Cells(i, 4) = 0 ThenRows(i).Delete Shift:=xlUpElsei = i + 1End IfWend行范围 = i + 1 '这里有中间计算过程，算出的是最终确立的，最后条数据的行号'完成行的确定title = Cells(1, 1)Rows(2).Delete Shift:=xlUpRows(2).Insert Shift:=xlDownRows("4:5").Insert Shift:=xlDown'删除第一列与第四列Columns(1).Delete Shift:=xlToLeftColumns(3).Delete Shift:=xlToLeft'去掉含不计入综测的科目有效范围 = 2 * (i - 3) / 3j = 3While Cells(3, j) <> ""计数 = 0For i = 6 To 行范围If Len(Cells(i, j)) Then计数 = 计数 + 1End IfNext'①成绩比例小于2/3 ②形势与政策、专业导论等只分合格与不合格的不计入(该处采用不严密的算法，但出错,即定位的6位同学都没有出现“合格”字眼几乎是不可能事件)If (计数 < 有效范围) ThenColumns(j).Delete Shift:=xlToLeftElseIf (Mid(Cells(6, j), 1, 2) = "合格") Or (Mid(Cells(10, j), 1, 2) = "合格") Or (Mid(Cells(20, j), 1, 2) = "合格") ThenColumns(j).Delete Shift:=xlToLeftElseIf (Mid(Cells(25, j), 1, 2) = "合格") Or (Mid(Cells(28, j), 1, 2) = "合格") Or (Mid(Cells(30, j), 1, 2) = "合格") ThenColumns(j).Delete Shift:=xlToLeftElsej = j + 1End IfWend列范围 = j - 1Range(Cells(1, 1), Cells(1, 列范围)).FormulaR1C1 = title '有个标题会没掉的BUG，不知道问题在哪，所以在此处补充回来'提取出第三行的科目类型、科目名称、学分数据Dim 第一个位置, 第二个位置, 长度    '找出斜杆的位置For j = 3 To 列范围i = 1Cells(3, j).SelectWhile Mid(ActiveCell, i, 1) <> "/"i = i + 1Wend第一个位置 = ii = i + 1While Mid(ActiveCell, i, 1) <> "/"i = i + 1Wend第二个位置 = i长度 = Len(ActiveCell)Cells(2, j) = Mid(ActiveCell, 第一个位置 + 1, 第二个位置 - 第一个位置 - 1)Cells(4, j) = Mid(ActiveCell, 第二个位置 + 1, 长度 - 第二个位置)Cells(3, j) = Left(ActiveCell, 第一个位置 - 1)Next'下面是列交换，先按科目类别名降序排序，再按学分降序排序,完成列的交换Range(Cells(2, 3), Cells(行范围, 列范围)).SelectActiveSheet.Sort.SortFields.ClearActiveSheet.Sort.SortFields.Add Key:=Range(Cells(2, 3), Cells(2, 列范围)), _SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormalActiveSheet.Sort.SortFields.Add Key:=Range(Cells(4, 3), Cells(4, 列范围)), _SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormalWith ActiveSheet.Sort.SetRange Range(Cells(2, 3), Cells(行范围, 列范围)).Header = xlGuess.MatchCase = False.Orientation = xlLeftToRight.SortMethod = xlPinYin.ApplyEnd With'第二行类别名相同合并i = 3While i <= 列范围j = i + 1While Cells(2, j) = Cells(2, i)Cells(2, j).Clearj = j + 1WendIf j = i + 1 ThenCells(2, i).MergeCells = FalseElseRange(Cells(2, i), Cells(2, j - 1)).MergeCells = TrueEnd Ifi = jWend'所有缺数据的地方用0分填充,考察课文本转为数值成绩For i = 6 To 行范围For j = 3 To 列范围Cells(i, j).SelectIf Len(ActiveCell) = 0 ThenCells(i, j) = "0"ElseSelect Case ActiveCellCase "优秀"ActiveCell = 90Case "良好"ActiveCell = 80Case "中等"ActiveCell = 70Case "及格"ActiveCell = 60Case "不及格"ActiveCell = 50End SelectEnd IfNextNext'再做些小修改后，进入下一个阶段Cells(5, 1) = Cells(3, 1)Cells(5, 2) = Cells(3, 2)Cells(3, 1).ClearCells(3, 2).ClearCells(2, 1) = "课程类别"Range(Cells(2, 1), Cells(2, 2)).MergeCells = TrueCells(3, 1) = "课程名称"Range(Cells(3, 1), Cells(3, 2)).MergeCells = TrueRange(Cells(4, 1), Cells(4, 2)).MergeCells = TrueRange(Cells(1, 1), Cells(1, 列范围 + 3)).MergeCells = TrueCells(2, 列范围 + 1) = "加权平均分"Cells(2, 列范围 + 2) = "学业基本分"Cells(2, 列范围 + 3) = "排名"Range(Cells(2, 列范围 + 1), Cells(4, 列范围 + 1)).MergeCells = TrueRange(Cells(2, 列范围 + 2), Cells(4, 列范围 + 2)).MergeCells = TrueRange(Cells(2, 列范围 + 3), Cells(4, 列范围 + 3)).MergeCells = True'进入下一阶段Dim 区域 As Rangei = 6While Cells(i, 1) <> ""i = i + 1Wend行范围 = ii = 3While Cells(4, i) <> ""i = i + 1Wend列范围 = i + 3'窗口拆分与冻结Range("C5").SelectWith ActiveWindow.SplitColumn = 2.SplitRow = 4End WithActiveWindow.FreezePanes = True'前四行表头填充颜色Range(Cells(1, 1), Cells(1, 列范围 - 1)).SelectWith Selection.Interior.Pattern = xlSolid.PatternColorIndex = xlAutomatic.Color = 16764108.TintAndShade = 0.PatternTintAndShade = 0End WithRange(Cells(2, 1), Cells(4, 列范围 - 4)).SelectWith Selection.Interior.Pattern = xlSolid.PatternColorIndex = xlAutomatic.Color = 16764057.TintAndShade = 0.PatternTintAndShade = 0End WithRange(Cells(2, 列范围 - 3), Cells(4, 列范围 - 1)).SelectWith Selection.Interior.Pattern = xlSolid.PatternColorIndex = xlAutomatic.Color = 13421619.TintAndShade = 0.PatternTintAndShade = 0End With'全表格单元格格式统一Range(Cells(1, 1), Cells(行范围 - 1, 列范围 - 1)).SelectWith Selection.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenter.WrapText = True.Orientation = 0.AddIndent = False.IndentLevel = 0.ShrinkToFit = False.ReadingOrder = xlContextEnd WithWith Selection.Font.Name = "微软雅黑".FontStyle = "常规".Size = 12.Strikethrough = False.Superscript = False.Subscript = False.OutlineFont = False.Shadow = False.Underline = xlUnderlineStyleNone.TintAndShade = 0.ThemeFont = xlThemeFontNoneEnd WithFor i = 3 To 列范围 - 4If Len(Cells(3, i)) < 16 ThenCells(3, i).Font.Size = 10     '课程名称用10号字体ElseCells(3, i).Font.Size = 8       '课程名称大于15个字时用8号字体End IfNextFor i = 3 To (列范围 - 1)                                   '课程类别只有单科目时字体要缩小点，不然难看If Cells(2, i).MergeCells = False ThenCells(2, i).Font.Size = 10End IfNext'绘制网格线Range(Cells(1, 1), Cells(行范围 - 1, 列范围 - 1)).SelectSelection.Borders(xlDiagonalDown).LineStyle = xlNoneSelection.Borders(xlDiagonalUp).LineStyle = xlNoneWith Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous.ColorIndex = 0.TintAndShade = 0.Weight = xlThinEnd WithWith Selection.Borders(xlEdgeTop).LineStyle = xlContinuous.ColorIndex = 0.TintAndShade = 0.Weight = xlThinEnd WithWith Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous.ColorIndex = 0.TintAndShade = 0.Weight = xlThinEnd WithWith Selection.Borders(xlEdgeRight).LineStyle = xlContinuous.ColorIndex = 0.TintAndShade = 0.Weight = xlThinEnd WithWith Selection.Borders(xlInsideVertical).LineStyle = xlContinuous.ColorIndex = 0.TintAndShade = 0.Weight = xlThinEnd WithWith Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous.ColorIndex = 0.TintAndShade = 0.Weight = xlThinEnd With'再进行科目成绩格式标准化For j = 3 To (列范围 - 4) Step 1'先判断出该列是否为考察课，是则logo记为1，否则记为0logo = 1For i = 6 To (行范围 - 1) Step 1If Cells(i, j) Mod 10 Thenlogo = 0Exit ForEnd IfNext iIf logo = 0 Then  '如果为非考查课，使用条件格式，不小于90分的以紫色背景标记Range(Cells(6, j), Cells(行范围 - 1, j)).SelectSelection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _Formula1:="=89.5"Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriorityWith Selection.FormatConditions(1).Interior.PatternColorIndex = xlAutomatic.Color = 10498160.TintAndShade = 0End WithSelection.FormatConditions(1).StopIfTrue = FalseEnd IfNext j'科目成绩小于60分的红色背景标记Range(Cells(6, 3), Cells(行范围 - 1, 列范围 - 4)).SelectSelection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _Formula1:="=60"Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriorityWith Selection.FormatConditions(1).Interior.PatternColorIndex = xlAutomatic.Color = 255.TintAndShade = 0End WithSelection.FormatConditions(1).StopIfTrue = FalseCells(4, 1).FormulaR1C1 = "=""学分/"" & SUM(R4C3:R4C" & (列范围 - 4) & ") & ""分"" "    'A4格的数据修正'第六行同学的加权平均分,学业基本分，排名计算Cells(6, 列范围 - 3).Selectstr = "=(0"For i = 3 To (列范围 - 4) Step 1str = str & "+R4" & "C" & i & "*IF(" & "R[0]C[" & (i - 列范围 + 3) & "]<60,0," & "R[0]C[" & (i - 列范围 + 3) & "])"Next istr = str & ")/SUM(" & "R4C3:R4C" & (列范围 - 4) & ")"Cells(6, 列范围 - 3).SelectActiveCell.FormulaR1C1 = strActiveCell.Offset(0, 1).FormulaR1C1 = "=0.9*R[0]C[-1]"ActiveCell.Offset(0, 2).FormulaR1C1 = "=RANK(R[0]C[-1],R6C" & (列范围 - 2) & ":R" & (行范围 - 1) & "C" & (列范围 - 2) & ",0)"'公式复制，计算出所有成绩Range(Cells(6, 列范围 - 3), Cells(6, 列范围 - 1)).SelectSelection.AutoFill Destination:=Range(Cells(6, 列范围 - 3), Cells(行范围 - 1, 列范围 - 1)), Type:=xlFillDefault'行高、列宽的调整,若使用者觉得不美观，也可以自己修改下面的参数Rows("1:1").RowHeight = 28.5Rows("2:2").RowHeight = 21.75Rows("3:3").RowHeight = 51Rows("4:200").RowHeight = 16Columns("A:A").ColumnWidth = 13Columns("B:B").ColumnWidth = 8.38str = "C:" & Chr(列范围 + 60)Columns(str).ColumnWidth = 8.18Columns(Chr(列范围 + 61) & ":" & Chr(列范围 + 62)).ColumnWidth = 11.25Columns(Chr(列范围 + 61) & ":" & Chr(列范围 + 62)).NumberFormatLocal = "0.00000_);[红色](0.00000)"  '加权平均值和学业基本分保留5位小数Columns(Chr(列范围 + 63)).ColumnWidth = 6.5'第五行设置筛选命令Range(Cells(5, 1), Cells(5, 列范围 - 1)).AutoFilterCells(5, 3).Select'工作表重命名If Mid(title, 13, 1) = 1 ThenActiveSheet.Name = "成绩表(上)"ElseActiveSheet.Name = "成绩表(下)"End IfMsgBox "友情提示" & vbCrLf & _"1、注意是否有同学含0分的科目，询问是否为缓考或免修。" & vbCrLf & _"2、了解后，把0分改为特定的数值即可。加权平均分，学业基本分，排名都是用公式完成的，会自动更新。" & vbCrLf & _"3、程序也不是万能的，如果遇到特殊情况，如交换生的成绩，要手动进行一些处理。"
End Sub

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

使用说明

文件下载：“测试数据.xlsm”

程序适用范围：对厦门理工教务系统给的原始成绩表，或其他来源，但具有相同排版的原始成绩表。

程序功能：对于每个班级的原始期末成绩表，自动完成综合测评中所需的“成绩表”，即获得综合测评中每位同学学业基本分及排名信息。

笔者使用软件：Microsoft Excel 2010

使用者需要了解的相关知识：①VBA，宏；②建议阅读下《学生手册》(厦门理工学院学生综合测评办法)第九条。要知道学业基本分是等于期末考试中，主要科目成绩的加权平均值乘以0.9得到的。学业基本分对综合测评总分起着主导作用。

注意事项：程序完成表格后，请仔细核对表格中成绩为0的地方，了解是否为缓考或免修，并直接改动对应地方的成绩，全表会自动更新。

使用方法基本介绍：下载 “测试数据.xlsm”文件,并打开，首界面如下

该工作薄有三张工作表，见左下方，“原始表格”的数据请勿修改，“结果展示”为运行后的效果展示，“测试副本”为供使用者做测试的数据。关闭文件时建议不要保存，以后可以重新进行实验。结果展示效果如下图：

测试方法：
①点击“测试副本”工作表
②点击“视图” -> 宏 -> 查看宏 -> 默认选择一个宏名为“成绩表”宏，点击执行
③稍等片刻，既能看到最终效果
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

程序实现步骤及原理（选读）

（一）前半阶段

0、原始成绩表也是由程序生成的，很有规律，所以我们能再写一个程序与其对接，用计算机自动制作我们所需的表格。很多看似需要人工干预的难题，其实都可以用非常巧妙的技巧来智能解决这些问题。以下将在程序实现步骤中，穿插讲解原理。
1、删除所有“获得学分”为0的行，这些同学一般是交换生等特殊情况，要么不计入综合测评，要么要用另外特殊的方法计算其学业基本分。
2、表格微调，删除第一列与第四列不再需要使用的信息。
3、去掉不参与综合测评的科目所在列。

这步很有技巧，《学生手册》对范围的解释是“学年所有必修课和规定选修课”。
①其实我们可以这样理解，假设一个班级60人，某门科目有成绩的学生不到40人，那么这门科目一般是体育课，校公选课等这些课程了。即某门科目有成绩的学生人数少于学生总数的2/3，即认定该门科目肯定不参与综合测评。
②另外，还有“形势与政策”，“专业导论”，虽然每个人都有成绩，但这类课程只有两个指标——“合格”或“不合格”，这种课程加入综合测评也是没有意义的，所以用程序进行判断，如果某门科目评定结果为“合格”或“不合格”，那么这列也可以删除。
这样筛选出的科目，99%的概率是正确的，万一真的遇到特殊情况，也可以在了解程序原理的情况下，事先对原始成绩表做些修改。
4、得到科目后，必须要知道每门科目的学分，原始成绩表第三行有这些数据，见下图

只要把数据按课程名称，课程类别，课程学分，三项内容分别读取出来，然后按照学科类别为主关键词，学分为次关键词，进行降序的列排列，就可以使课程整齐的展示出来。

课程类别放在第二行，并合并单元格；课程名称放在第三行；课程学分放在第四行。
5、
①成绩数据中，如果某同学没有该科成绩，一般是缓考或者申请免修，这需要最后手动解决。程序将先以0分自动填充。
②考察课，有“优秀”，“良好”，“中等”，“及格”，“不及格”等文本信息，只需把单元格数值相应替换为90,80,70,60,50即可。

6、然后进行细节的修改，如表头增加“加权平均分”，“学业基本分”，“排名”信息。一些单元格的合并。插入空白的第五行，使成绩数据从第六行开始。
至此，表格已经完成一半了，解决了很多棘手的问题。剩下的一半主要是数值计算。

（二）后半阶段
1、在“C5”设定窗口的拆分与冻结，方便表格的查阅。前四行的表头部分进行颜色填充，有点色彩更不会像黑白表格那样枯燥。
2、接着是全表格单元格格式的统一，统一用“微软雅黑”字体，除了个别部分10号字体，都是用12号字体。并绘制网格线。
3、接着要找出成绩不低于90分的单元格，以紫色背景突出显示，主要是日后另有用途，同时也作为一种表扬。但是考查课的“优秀”转换过来的“90”分不能标记。如何判断出某门科目是否为考查课呢？
原理很简单，考查课的话，所有人的成绩都是能被10整除的，如果不是，那该门就不是考查课。
同时，小于60分的单元格要以红色背景突出显示，这个就不区别是否为考查课了，该功能也是有用途的，并不是刻意要为难这些同学。
4、然后只需在第一个同学（在第六行）所在行对应的加权平均分，学业基本分，排名单元格，打入相应的计算公式即可。
①计算加权评均分，有个细节——小于60分的以0分计算。这个细节大大的增加了难度，但也是可以用公式完成的，采用IF函数，如果该单元格小于60，则返回值为0，否则返回单元格原本的数值。不过，这样公式会打的比较长。
②学业基本分只要用加权平均分×0.9即可得到。
③排名的话，很多人会先用学业基本分降序的方法，然后填写。不过现在是在VBA里面，这样操作很麻烦，而且这样完成的排名，一旦学业基本分有变动，是不会自动更新的。再一方面，那样下拉的排名，在出现有并列成绩时，会出错。所以我这里推荐更规范的操作——使用RANK函数。
完成第一个同学的数据后，用公式复制的方法填充所有行，全班的成绩就都出来了。
5、加权平均分，学业基本分保留5位有效数字；调整行高，列宽；在第五行添加筛选功能。整个成绩表就制作完成了。
6、顺便从标题判断上下学期，然后把该工作表重命名为“成绩表(上)”或"成绩表(下)"。

补充：该程序耗时两天两夜，我是先完成了后半阶段的程序，然后发现我可以做的更多，又写了前半阶段的程序，合起来成了一个完整的程序，并能直接与原始成绩表对接。所以后半段的VBA代码风格和前半段不一样，有兴趣看我代码的同学，要注意两部分的“行范围”，“列范围”变量的含义是不同的。

大学综合测评中，使用VBA代码自动完成EXCEL成绩表相关推荐

大学计算机学生成绩综合管理系统,大学综合测评成绩管理系统的研究计算机专业毕业论文.doc...
UNIVERSITY 毕业设计(论文) 设计(论文)题目: 系部: 计算机科学与技术系专业: 计算机科学与技术学生姓名: 班级: 学号指导教师姓名: 职称讲师最终评定成绩教务处 ...
工具推荐：用VS code 导出、导入和运行Excel中的VBA代码
问题如何使用Excel的VBA 编辑器以外的IDE来编辑VBA代码? 如何导入/导出Excel中的VBA代码? 我能不能在Excel以外的地方运行VBA代码? 如何把Excel中的VBA工程/代码上 ...
从带宏密码保护的Excel文件中导出VBA代码和Sheet
使用Excel的VBProject可以导出文件中的VBA代码,但是有的文件有宏密码保护,导出就会报错.在知道密码的前提下可以打开Excel后用代码自动填写密码,然后导出. 刚开始我尝试使用VBA去实现 ...
python怎么输入代码-python中如何设置代码自动提示
第一步:打开pycharm,如下图所示: 第二步:File→Power Save Mode,把下面如图所示的勾去掉: 第三步:去掉勾后,不再使用省电模式,新建一个 python文件,输入需要输入的单词 ...
oracle中修改多个字段默认值_利用VBA代码在已有的数据表中删除、添加、修改字段...
大家好,今日继续给大家讲解VBA数据库解决方案的第21讲,如何利用VBA代码在已有的数据表中删除,添加,修改字段.这个内容是操作数据库的一项必修的内容,还望大家在实际工作中多利用,所以这节的知识,对于 ...
c向文件中插入数据_如何把数据写入顺序文件中，VBA代码中Write#语句的利用
大家好,我们今日继续讲解VBA代码解决方案的第132讲内容:使用 Write #语句把数据写入打开顺序文件中.在上一讲的内容中我们讲了打开一文本文件来写入数据的两种方法有:Append或Output, ...
excel vba编程代码大全_实战VBA代码一键提取EXCEL中的所有公式！
有的时候,我们希望把表中的公式提取出来,进行保存! 少量,我们可以手动复制,量大,猝-- 所以我们今天就分享一下如何一键提取用什么,VBA上吧! 还是老规矩,我们先看一下动画效果动画效果制作教程 ...
中判断字符串是否为空_自己动手编写VBA代码，判断一个工作表是否为空，然后删除它...
大家好,我们今日继续讲解VBA代码解决方案的第57讲内容:判断工作表是否为空表.在实际的工作中,我们要常常判断某个工作表是否为空的,那么在VBA中是如何能做到这一点呢? VBA中没有专门的属性或函数可 ...
写了一段VBA代码后， Excel每次保存时都弹出警告：”此文档中包含宏、Activex控件、XML扩展包信息“（office 2007）
前言:今天在写一段VBA代码之后,遇到一个问题, Excel每次保存时就报一个警告(使用的是office 2007): 此文档中包含宏.Activex控件.XML扩展包信息用起来很不爽! ----- ...

大学综合测评中，使用VBA代码自动完成EXCEL成绩表

大学综合测评中，使用VBA代码自动完成EXCEL成绩表相关推荐

最新文章

热门文章