大学综合测评中，使用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 "优秀"