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

       更新：2014-04-18       下午

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

前言

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

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

代码

       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/6

    Dim 行范围, 列范围, 有效范围, 计数, i, j, title, 总学分, logo, str

    '去掉获得学分为0的行
    i = 4
    While Cells(i, 4) <> ""
        If Cells(i, 4) = 0 Then
            Rows(i).Delete Shift:=xlUp
        Else
            i = i + 1
        End If
    Wend
    行范围 = i + 1 '这里有中间计算过程，算出的是最终确立的，最后条数据的行号
    
    '完成行的确定
    title = Cells(1, 1)
    Rows(2).Delete Shift:=xlUp
    Rows(2).Insert Shift:=xlDown
    Rows("4:5").Insert Shift:=xlDown
    
    '删除第一列与第四列
    Columns(1).Delete Shift:=xlToLeft
    Columns(3).Delete Shift:=xlToLeft
    
    '去掉含不计入综测的科目
    有效范围 = 2 * (i - 3) / 3
    j = 3
    While Cells(3, j) <> ""
        计数 = 0
        For i = 6 To 行范围
            If Len(Cells(i, j)) Then
                计数 = 计数 + 1
            End If
        Next
        '①成绩比例小于2/3 ②形势与政策、专业导论等只分合格与不合格的不计入(该处采用不严密的算法，但出错,即定位的6位同学都没有出现“合格”字眼几乎是不可能事件)
        If (计数 < 有效范围) Then
            Columns(j).Delete Shift:=xlToLeft
        ElseIf (Mid(Cells(6, j), 1, 2) = "合格") Or (Mid(Cells(10, j), 1, 2) = "合格") Or (Mid(Cells(20, j), 1, 2) = "合格") Then
            Columns(j).Delete Shift:=xlToLeft
        ElseIf (Mid(Cells(25, j), 1, 2) = "合格") Or (Mid(Cells(28, j), 1, 2) = "合格") Or (Mid(Cells(30, j), 1, 2) = "合格") Then
            Columns(j).Delete Shift:=xlToLeft
        Else
            j = j + 1
        End If
    Wend
    列范围 = j - 1
    Range(Cells(1, 1), Cells(1, 列范围)).FormulaR1C1 = title '有个标题会没掉的BUG，不知道问题在哪，所以在此处补充回来
    
    '提取出第三行的科目类型、科目名称、学分数据
    Dim 第一个位置, 第二个位置, 长度    '找出斜杆的位置
    For j = 3 To 列范围
        i = 1
        Cells(3, j).Select
        While Mid(ActiveCell, i, 1) <> "/"
            i = i + 1
        Wend
        第一个位置 = i
        i = i + 1
        While Mid(ActiveCell, i, 1) <> "/"
            i = i + 1
        Wend
        第二个位置 = 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(行范围, 列范围)).Select
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(2, 3), Cells(2, 列范围)), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(4, 3), Cells(4, 列范围)), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range(Cells(2, 3), Cells(行范围, 列范围))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    
    '第二行类别名相同合并
    i = 3
    While i <= 列范围
        j = i + 1
        While Cells(2, j) = Cells(2, i)
            Cells(2, j).Clear
            j = j + 1
        Wend
        If j = i + 1 Then
            Cells(2, i).MergeCells = False
        Else
            Range(Cells(2, i), Cells(2, j - 1)).MergeCells = True
        End If
        i = j
    Wend
    
    '所有缺数据的地方用0分填充,考察课文本转为数值成绩
    For i = 6 To 行范围
        For j = 3 To 列范围
            Cells(i, j).Select
            If Len(ActiveCell) = 0 Then
                Cells(i, j) = "0"
            Else
                Select Case ActiveCell
                    Case "优秀"
                        ActiveCell = 90
                    Case "良好"
                        ActiveCell = 80
                    Case "中等"
                        ActiveCell = 70
                    Case "及格"
                        ActiveCell = 60
                    Case "不及格"
                        ActiveCell = 50
                End Select
            End If
        Next
    Next
    
    '再做些小修改后，进入下一个阶段
    Cells(5, 1) = Cells(3, 1)
    Cells(5, 2) = Cells(3, 2)
    Cells(3, 1).Clear
    Cells(3, 2).Clear
    Cells(2, 1) = "课程类别"
    Range(Cells(2, 1), Cells(2, 2)).MergeCells = True
    Cells(3, 1) = "课程名称"
    Range(Cells(3, 1), Cells(3, 2)).MergeCells = True
    Range(Cells(4, 1), Cells(4, 2)).MergeCells = True
    Range(Cells(1, 1), Cells(1, 列范围 + 3)).MergeCells = True
    Cells(2, 列范围 + 1) = "加权平均分"
    Cells(2, 列范围 + 2) = "学业基本分"
    Cells(2, 列范围 + 3) = "排名"
    Range(Cells(2, 列范围 + 1), Cells(4, 列范围 + 1)).MergeCells = True
    Range(Cells(2, 列范围 + 2), Cells(4, 列范围 + 2)).MergeCells = True
    Range(Cells(2, 列范围 + 3), Cells(4, 列范围 + 3)).MergeCells = True
    
    '进入下一阶段
    Dim 区域 As Range
    i = 6
    While Cells(i, 1) <> ""
        i = i + 1
    Wend
    行范围 = i
    
    i = 3
    While Cells(4, i) <> ""
        i = i + 1
    Wend
    列范围 = i + 3
    
    '窗口拆分与冻结
    Range("C5").Select
    With ActiveWindow
        .SplitColumn = 2
        .SplitRow = 4
    End With
    ActiveWindow.FreezePanes = True
    
    '前四行表头填充颜色
    Range(Cells(1, 1), Cells(1, 列范围 - 1)).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 16764108
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range(Cells(2, 1), Cells(4, 列范围 - 4)).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 16764057
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range(Cells(2, 列范围 - 3), Cells(4, 列范围 - 1)).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 13421619
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    '全表格单元格格式统一
    Range(Cells(1, 1), Cells(行范围 - 1, 列范围 - 1)).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    With Selection.Font
        .Name = "微软雅黑"
        .FontStyle = "常规"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    For i = 3 To 列范围 - 4
        If Len(Cells(3, i)) < 16 Then
            Cells(3, i).Font.Size = 10     '课程名称用10号字体
        Else
            Cells(3, i).Font.Size = 8       '课程名称大于15个字时用8号字体
        End If
    Next
    For i = 3 To (列范围 - 1)                                   '课程类别只有单科目时字体要缩小点，不然难看
        If Cells(2, i).MergeCells = False Then
            Cells(2, i).Font.Size = 10
        End If
    Next
    
    '绘制网格线
    Range(Cells(1, 1), Cells(行范围 - 1, 列范围 - 1)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    
    '再进行科目成绩格式标准化
    For j = 3 To (列范围 - 4) Step 1
        '先判断出该列是否为考察课，是则logo记为1，否则记为0
        logo = 1
        For i = 6 To (行范围 - 1) Step 1
            If Cells(i, j) Mod 10 Then
                logo = 0
                Exit For
            End If
        Next i
        
        If logo = 0 Then  '如果为非考查课，使用条件格式，不小于90分的以紫色背景标记
            Range(Cells(6, j), Cells(行范围 - 1, j)).Select
            Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
                Formula1:="=89.5"
            Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
            With Selection.FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .Color = 10498160
                .TintAndShade = 0
            End With
            Selection.FormatConditions(1).StopIfTrue = False
        End If
    Next j
    
    '科目成绩小于60分的红色背景标记
    Range(Cells(6, 3), Cells(行范围 - 1, 列范围 - 4)).Select
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _
        Formula1:="=60"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    
    Cells(4, 1).FormulaR1C1 = "=""学分/"" & SUM(R4C3:R4C" & (列范围 - 4) & ") & ""分"" "    'A4格的数据修正
    
    '第六行同学的加权平均分,学业基本分，排名计算
    Cells(6, 列范围 - 3).Select
    str = "=(0"
    For i = 3 To (列范围 - 4) Step 1
        str = str & "+R4" & "C" & i & "*IF(" & "R[0]C[" & (i - 列范围 + 3) & "]<60,0," & "R[0]C[" & (i - 列范围 + 3) & "])"
    Next i
    str = str & ")/SUM(" & "R4C3:R4C" & (列范围 - 4) & ")"
    Cells(6, 列范围 - 3).Select
    ActiveCell.FormulaR1C1 = str
    ActiveCell.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)).Select
    Selection.AutoFill Destination:=Range(Cells(6, 列范围 - 3), Cells(行范围 - 1, 列范围 - 1)), Type:=xlFillDefault
    
    '行高、列宽的调整,若使用者觉得不美观，也可以自己修改下面的参数
    Rows("1:1").RowHeight = 28.5
    Rows("2:2").RowHeight = 21.75
    Rows("3:3").RowHeight = 51
    Rows("4:200").RowHeight = 16
    Columns("A:A").ColumnWidth = 13
    Columns("B:B").ColumnWidth = 8.38
    str = "C:" & Chr(列范围 + 60)
    Columns(str).ColumnWidth = 8.18
    Columns(Chr(列范围 + 61) & ":" & Chr(列范围 + 62)).ColumnWidth = 11.25
    Columns(Chr(列范围 + 61) & ":" & Chr(列范围 + 62)).NumberFormatLocal = "0.00000_);[红色](0.00000)"  '加权平均值和学业基本分保留5位小数
    Columns(Chr(列范围 + 63)).ColumnWidth = 6.5

    '第五行设置筛选命令
    Range(Cells(5, 1), Cells(5, 列范围 - 1)).AutoFilter
    Cells(5, 3).Select
    
    '工作表重命名
    If Mid(title, 13, 1) = 1 Then
        ActiveSheet.Name = "成绩表(上)"
    Else
        ActiveSheet.Name = "成绩表(下)"
    End If
    
    MsgBox "友情提示" & 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代码风格和前半段不一样，有兴趣看我代码的同学，要注意两部分的“行范围”，“列范围”变量的含义是不同的。