关于各班各科成绩统计的最终定稿

前面关于各班各科成绩统计分析的已经写了两篇了,刚刚看了看,发现总是有这样那样的毛病,既然今天下午没有什么事,干脆就重新整理一下吧.

按现在的考试流程分析,可以分为以下几步:

①一卷成绩的导入/二卷成绩的导入;②按理类/科目将一/二卷合并;③计算总分;④分析成绩,并计算总名次及班名次.

其中分析成绩基本有两种类型,一种是按类似50名一段进行分析,统计各班各科各名次段人数,另一种是按指定名次进行分析;此外,还需要计算各班各平的平均分(这一步一般是将各班各科后5名学生去掉,因为后5名的学生往往都是未参加考试.)

第1步:关于一/二卷成绩的导入,格式要求:A列为考试号,B列为I卷或II卷成绩,顺序无所谓,文件名以"**1.xls"或"**.2xls"保存,其中"**1.xls"为I卷成绩,"**2.xls"为II卷成绩.对于语文/数学/外语,尤其是数学文理科试题不一样,但由于是通过字典功能来实现成绩导入,故无所谓.也就是语/数/外三科最好不用分开,只要有考试号就可以自动区别.

新建一工作簿"原始成绩.xls",其中的sheet1命名为"文科",sheet2命名为"理科",分别用来保存各科的原始成绩.并将文/理科学生的考试号放入,以便于生成字典.

第2步:导入功能的实现.现在有点明白字典及数组的用法了.尤其是对多维数组的用法!!

上面是文科的原始成绩示意图,最终效果应如下图所示:

源程序如下:

Option Explicit
Option Base 1
Sub 导入文科原始成绩()
    Application.ScreenUpdating = False
    Dim i As Integer, j As Integer, TotalR As Integer, k As Integer
    Dim km(6) As String
    km(1) = "语文"
    km(2) = "数学"
    km(3) = "外语"
    km(4) = "政治"
    km(5) = "历史"
    km(6) = "地理"
    '转入正式程序设计
    Dim dic As Object, wb As Object
    Dim arr()
    Dim arr1()
    For i = 1 To 6
        For j = 1 To 2
            Set wb = GetObject(ThisWorkbook.Path & "" & km(i) & Trim(Str(j) & ".xls")) '创建一个工作簿对象,这样可不用再打开各科工作簿了,明显的节省时间.
            'Debug.Print wb.Name
            TotalR = wb.Sheets(1).Range("A65536").End(xlUp).Row '取得wb工作簿对象的行数,这种方式只适合于读取数据,不能写入数据,要想写入数据,必须将对应工作簿实际打开才可.此处若不加wb则默认为代码所在工作簿了,所以务必要加.
            arr = wb.Sheets(1).Range("A1").Resize(TotalR, 2).Value '生成了一个totalR行,2列的一个二维数组.这种用法要逐步习惯!!
            wb.Close False '给数组赋值结束后,及时将工作簿对象关闭,以节省内存,提高效率.
            Set dic = CreateObject("scripting.dictionary") '创建字典
            For k = 2 To UBound(arr)
                dic(arr(k, 1)) = arr(k, 2) '以arr(k,1)即考试号为关键字,arr(k,2)为条目
                'Debug.Print arr(k, 2)
            Next k
            Erase arr '创建完字典,由于arr数组原有内容已无用处,及时清掉,为下面的应用做准备.
            Sheets(1).Activate '激活需要填入成绩的工作表,其实不用激活也可以.
            TotalR = Range("A65536").End(xlUp).Row '取得当前工作表的行数
            arr = Range("A1").Resize(TotalR, Range("IV2").End(xlToLeft).Column + 1).Value '创建一个totalR行,Range("IV2").End(xlToLeft).Column + 1列的多维数组,数组最多不能超过60维!
            For k = 1 To UBound(arr) '由于字典中的关键字(考试号)对应着arr数组中的第1列,故可以按关键字将对应条目(单科成绩)赋值给arr数组的第Range("IV2").End(xlToLeft).Column + 1列.
                arr(k, Range("IV2").End(xlToLeft).Column + 1) = dic(arr(k, 1))
                'Debug.Print arr(k, Range("IV2").End(xlToLeft).Column + 1)
            Next k
            '利用index工作表函数将arr数组里的第Range("IV2").End(xlToLeft).Column + 1列的值赋给相应单元格,由于arr数组就是从工作表中取得的,所以肯定是一一对应的.所以直接赋值即可.
            Cells(1, Range("IV2").End(xlToLeft).Column + 1).Resize(TotalR, 1).Value = Application.WorksheetFunction.Index(arr, 0, Range("IV2").End(xlToLeft).Column + 1)
'以下注释行一样可以实现相同的效果,只是不如上面这一句显得简洁,
'            'Debug.Print Format(UBound(arr))
'            ReDim arr1(UBound(arr))
'            Range("A1").Resize(Range("A65536").End(3).Row, Range("IV2").End(xlToLeft).Column + 1).NumberFormatLocal = "@"
'            For k = 1 To UBound(arr)
'                arr1(k) = arr(k, Range("IV2").End(xlToLeft).Column + 1) '将多维数组中的成绩维转换成一维数组
'                'Debug.Print arr1(k)
'            Next k
'            '以下三行一样可以实现!!现在有三种方式可以应用,这是第一次啊.
''            For k = 1 To UBound(arr1)
''                Cells(k, Range("IV" & Trim(Str(k))).End(xlToLeft).Column + 1).Value = arr1(k)
''            Next k
'            Cells(1, Range("IV2").End(xlToLeft).Column + 1).Resize(TotalR, 1).Value = Application.WorksheetFunction.Transpose(arr1)
'            Erase arr1

'赋完值及时将arr清空,以便于下次循环使用.
            Erase arr
        Next j
    Next i
    '最后添加表头,很好,明白什么意思了.
    For i = 1 To 6
        For j = 1 To 2
            Cells(1, Range("IV1").End(xlToLeft).Column + 1).Value = km(i) & Trim(Str(j))
        Next j
    Next i
    Application.ScreenUpdating = True
End Sub

附:Index工作表函数的用法说明

返回由行和列编号索引选定的表或数组 （数组:用于建立可生成多个结果或可对在行和列中排列的一组参数进行运算的单个公式。数组区域共用一个公式；数组常量是用作参数的一组常量。）中的元素值。

如果 INDEX 的第一个参数是数组常量，请使用数组形式。

INDEX(array,row_num,column_num)

Array     是一个单元格区域或数组常量。

• 如果数组中只包含一行或一列，则可以不使用相应的 row_num 或 column_num 参数。
• 如果数组中包含多个行和列，但只使用了 row_num 或 column_num，INDEX 将返回数组中整行或整列的数组。

Row_num     用于选择要从中返回值的数组中的行。如果省略 row_num，则需要使用 column_num。

Column_num     用于选择要从中返回值的数组中的列。如果省略 column_num，则需要使用 row_num。

说明

• 如果同时使用了 row_num 和 column_num 参数，INDEX 将返回 row_num 和 column_num 交叉处单元格中的值。
• 如果将 row_num 或 column_num 设置为 0（零），INDEX 将分别返回整列或整行的值数组。要将返回的值用作数组，请在行的水平单元格区域和列的垂直单元格区域以数组公式 （数组公式:数组公式对一组或多组值执行多重计算，并返回一个或多个结果。数组公式括于大括号 ({ }) 中。按 Ctrl+Shift+Enter 可以输入数组公式。）的形式输入 INDEX 函数。要输入数组公式，请按 Ctrl+Shift+Enter。
• Row_num 和 column_num 必须指向数组中的某个单元格；否则，INDEX 将返回 #REF! 错误值。

附:关于字典与数组应用的一个例子,可以用来比较不同值,并将不同值提出.

源程序如下

Sub 提取不存在的数据并将结果保存()
    '将A列中的数据与B列相比较,输出B列中没有的数据到C列
    Dim arr, brr, i&, x&, d As Object
    arr = Range("a1:a" & [a65536].End(xlUp).Row) '给数组赋值
    brr = Range("B1:B" & [B65536].End(xlUp).Row) '给数组赋值
    Set d = CreateObject("scripting.dictionary") '创建字典
    For i = 1 To UBound(arr) '给字典赋值,关键字为arr(i,1),条目为空即可
        d(arr(i, 1)) = ""
    Next
    For x = 1 To UBound(brr) '若brr(x,1)关键字存在,则说明重复,故从字典中将该关键字移除.
        If d.exists(brr(x, 1)) Then
            d.Remove brr(x, 1)
        End If
    Next
    [C1].Resize(d.Count, 1) = Application.Transpose(d.keys) '最终完成后将字典的关键字赋给相应单元格,注意其中d.keys为关键字列表,因为为一维默认为行,故需转置一下才可填入列当中.
End Sub

第3步:计算各科及总分

Sub 计算各科成绩及总分()
    Dim km(7) As String
    km(1) = "语文"
    km(2) = "数学"
    km(3) = "外语"
    km(4) = "物理"
    km(5) = "化学"
    km(6) = "生物"
    km(7) = "总分"
    '转入正式程序设计
    Dim i As Integer, TotalR As Integer, j As Integer
    TotalR = Range("A65536").End(xlUp).Row
    '计算单科
    For i = 1 To 6
        For j = 2 To TotalR
            Cells(j, i + 13).Value = Cells(j, i + i).Value + Cells(j, i + i + 1)
        Next j
    Next i
    '计算总分
    For j = 2 To TotalR
        Cells(j, 20).Value = Application.WorksheetFunction.Sum(Range(Cells(j, 14), Cells(j, 19)))
    Next j
    '添加科目名称
    For i = 1 To 7
        Cells(1, Range("IV1").End(xlToLeft).Column + 1).Value = km(i)
    Next i
End Sub

 今天你菊子曰了么？