评教数据整理专用VBA小程序

这次评教的所有数据存放在两个数据库中，比如说给某教师评论的学生有100个，可是结果有40个的数据在数据库A中，另外60人的数据在数据库B中。那么，如何将两个库中的数据整合，最后得到教师的准确成绩成为了本次数据整理的首要任务。具体的整合过程是这样的，就拿教师的最终得分来说吧。假设库A学生给教师评价的平均分为90分，而库

B学生评价的平均分为95分。那么首先需要分别计算出库A、库B中学生评价的总分，库A总分 = 90*40 ，库B总分 = 95*60，教师所得总平均分 = （库A总分 + 库B总分）/ 两个库中学生总数。这仅仅是总分一项，之后的各小项得分都需要如此计算。一共大概有300多教师，每个教师都需要如此计算一遍。如果手动计算的话，估计得整理到猴年马月。于是乎，我决定写一个小程序来整理数据，使用的工具就是office里自带的VBA，下面是具体的代码：

'''作    者：王海涛
'''时    间：2013年6月29日10:10:51
'''过程说明：此过程为多个库中评教数据合并专用过程。主要功能是计算某教师、某课程在多个库中学生评分
'''          的平均值。
'''使用说明：处理的Excel必须是直接从评教系统导出的Excel，不得更换Excel中列的顺序。

Sub formatting()
  'On Error Resume Next '出现错误继续执行下一句
    Dim rowCount As Integer '总行数
    Dim colCount As Integer '总列数
    Dim tempRowCount As Integer '临时行数
    Dim tempColumnCount As Integer '临时列数
    Dim arrResult(100) As String '存放临时结果
    Dim strSheetName As String '存放原工作表名
    Dim sheetResult As Worksheet '自定义的工作表
    Dim newSheetName As String '新工作表名

    strSheetName = ActiveSheet.Name '取得当前Sheet的名字

    '=======================判断工作表的名称是否存在，如果存在，将其删除===============
    For Each tempSheet In Sheets '遍历所有的Sheet
         '判断工作表的名称是否存在，如果存在，将其删除
        If tempSheet.Name = "mySheet" Or tempSheet.Name = strSheetName + "整理结果" Then
            Application.DisplayAlerts = False
            tempSheet.Delete
            Application.DisplayAlerts = True
        End If
    Next
    '=================================================================================

    newSheetName = "mySheet"  '指定工作表名
    Set sheetResult = Worksheets.Add '增加工作表
    sheetResult.Name = newSheetName

    Sheets(strSheetName).Activate '将原始表设为当前活动表

    '操作原始表
    With Sheets(strSheetName)
        'rowCount = [b65536].End(xlUp).Row 获得当前工作表总行数
        rowCount = UsedRange.Rows.Count '获得当前工作表总行数
        colCount = UsedRange.Columns.Count '获得当前工作表总列数

        Sheets("mySheet").Rows.Insert '新工作表中添加行
        Rows(1).Copy Sheets("mySheet").Cells(1, 1) '将原始表中的第一行内容复制到目标工作表中

        '==================================以下For循环说明===============================
        '从第二行开始遍历以后所有行，遍历到每一行时，执行如下操作
        '重新遍历所有行，找到与当前行老师、课程一样的数据（说明在多个库中都有这个老师的数据），
        '然后将其合并。具体合并过程为：首先算出所有学生评论的总分数、各项的总分数，然后分别用
        '总分数除以总评估人数，得到所有学生评论的平均分。

        '比如：同一老师、同一课程有两行数据，那么
        '第一行学生评论总分数 = 第一行已评估人数 * 第一行平均分（这里是总分字段）
        '第二行学生评论总分数 = 第二行已评估人数 * 第二行平均分（这里是总分字段）
        '学生评论总分数 = 第一行学生评论总分数 + 第二行学生评论总分数
        '总评估人数 = 第一行已评估人数 + 第二行已评估人数
        '教师最终得分 = 学生评论总分数 / 总评估人数

        '其余各项得分算法与总分算法一样。
        '====================================================================================
        For i = 2 To rowCount '从第二行开始遍历以后所有行

            '=====================给数组赋值,将当前遍历行的数据存到数组里=========================
            '1到6分别存学院、教师、课程类型、课程、已评估人数、参评人数
            For tempColumnCount = 1 To 6
                arrResult(tempColumnCount) = Cells(i, tempColumnCount).Value
            Next tempColumnCount
            '从总分开始，以后的数组存学生给对应列分数的总和。比如：所有学生评论总分 = 已评估人数 * 平均分数（这里指的是总分）
            For tempColumnCount = 7 To colCount
                'Cells(i, 5).Value中的数据为已评估人数
                arrResult(tempColumnCount) = Val(Cells(i, tempColumnCount).Value) * Val(Cells(i, 5).Value)
            Next tempColumnCount
            '=================================数组赋值结束=========================================

            '开始寻找与当前老师、课程一样的数据（多个库中有的数据），并计算总分数==================
            For tempRowCount = 2 To rowCount '所在行的内容和所有行的内容比较
                If tempRowCount <> i Then '有效数据是不同与所选行的数据
                    Dim flag As Boolean '用来标记是否为同一老师同一门课程
                    flag = True

                    '前四列和第六列，只要有一列与目标数据不一样，说明此条数据不是和目标数据一样的数据，不需要合并
                    For tempColumnCount = 1 To 6 '比较前六列的值
                        If tempColumnCount <> 5 Then
                            If Cells(tempRowCount, tempColumnCount).Value <> Cells(i, tempColumnCount).Value Then
                               flag = False
                            End If
                        End If
                    Next tempColumnCount

                    '如果是同一老师同一门课程
                    If flag Then
                        '评估总人数 = 之前的评估人数 + 本行中的评估人数
                        arrResult(5) = Val(arrResult(5)) + Val(Cells(tempRowCount, 5).Value)

                        '从总分开始，数组值等于当前总值加上当前行对应的总值。比如：所有学生评论总分 = 之前学生评论总分 + 本行已评估人数 * 本行平均分数（这里指的是总分）
                        For tempColumnCount = 7 To colCount
                            arrResult(tempColumnCount) = Val(arrResult(tempColumnCount)) + Val(Cells(tempRowCount, tempColumnCount).Value) * Val(Cells(tempRowCount, 5).Value)
                        Next tempColumnCount
                    End If
                End If
            Next tempRowCount
            '===============================计算总分数结束===============================================

            '将整理结果写到新的工作表中

            For tempColumnCount = 1 To 6
                Sheets("mySheet").Cells(i, tempColumnCount).Value = arrResult(tempColumnCount)
            Next tempColumnCount
            '从总分开始，以后的值等于数组中对应的数值除以总已评估人数。比如：总分 = 数组中对应的总分值 / 已评估人数
            For tempColumnCount = 7 To colCount
                Sheets("mySheet").Cells(i, tempColumnCount).Value = Val(arrResult(tempColumnCount)) / Val(arrResult(5))
            Next tempColumnCount

            '如果评估总人数超过参评人数，则评估人数等于参评人数
            If Val(Sheets("mySheet").Cells(i, 5).Value) > Val(Sheets("mySheet").Cells(i, 6).Value) Then
                Sheets("mySheet").Cells(i, 5).Value = Sheets("mySheet").Cells(i, 6).Value
            End If
        Next i
        '====================================数据计算结束=======================================================

        '更改新建的工作表名
        sheetResult.Name = strSheetName + "整理结果"
    End With
End Sub

有了这个小程序，之前可能花费几天时间整理的数据，现在只需几分钟即可。再一次感受到了微软office的强大之处，只有你想不到，没有它做不到！