更新: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/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 "优秀"