VBA实战案例：处理挂科数据

最新推荐文章于 2024-06-22 08:30:38 发布

高开低走。

最新推荐文章于 2024-06-22 08:30:38 发布

阅读量816

点赞数

分类专栏：锦到说VBA

本文链接：https://blog.csdn.net/qq_43568982/article/details/104203860

版权

锦到说VBA 专栏收录该内容

37 篇文章 24 订阅

订阅专栏

问题描述：要求统计全年级同学的挂科情况数据为所有同学自从大一入学以来的所有成绩如果同学挂科了，就累加其所挂科的学分，学分大于30为红色预警，大于16小于30为橙色预警，大于8小于16为黄色预警

源数据:

在这里插入图片描述

效果预览：

在这里插入图片描述

问题分析

虽然数据有很多，但是有些数据并没有统计意义，我们需要关注的数据主要是学号，姓名，课程，学分以及绩点，绩点如果为0，说明这门课挂科了。

于是初步设想可以使先遍历学号字段，因为学号列是唯一标识，每个人都不一样，找到学号相同的，继续去找其科目，如果绩点为0，那么找到其学分字段，累加，将结果输出到新的工作簿里面。

判断是否为同一个人，可以用
if Cells(i, ID) = Cells(i + 1, ID) then
如果同，则进行下一步操作

判断学号可以根据上下关系，先按学号排好序，将相同的学号放在了一起。

但是判断科目就有一定难度了，因为一门课一个同学可能修过多次，比如模电，有些同学修了五次，一次都没有通过，这个时候他的学分我们只能记录一次的学分；还有可能一个同学修了三次，第三次通过了，那么这门课就不能算为挂科数据了。而因为学号并不是一个类，没办法用学号.科目进行处理。这个时候最好再次进行排序，把相同的科目放在一起，这样方便比较一点。

而当我们把科目放在了一起，又需要判断他的所有科目中是否有绩点为0的情况
，也要判断为0的科目，这门科目是否有绩点不为0的情况，我想的办法是，将科目按照名称排好序，再把绩点作为关键字升序排序，这样在两门科目交界的地方，前一门科目对应的绩点，就是这门科目所取得的最高绩点，如果这个绩点不为0，那么这门课一定是通过了的。如果这门课为0了，那么复制这一整行到新表，以备用。

当我们这一步处理完后，新工作簿里面应该装得是所有同学的挂科情况，同一门课多次挂科也只保留了一次。拿到这个之后就方便统计了。

这个时候，我们需要考虑的就是学号和绩点这两个字段
如果上下两组数据的学号相同，那么用一个count累加其学分字段
如果两组数据学号不同，就输出count，再把count清零用于下一组数据统计

当把上述数据都统计，复制到新工作簿之后
写一个判断语句遍历从上到下的数据，按照预警级别要求进行分类，并把相应同学所在行用对应颜色注明

最后再把得到的数据用数据透视表透视，可以清楚知道各个班所挂同学的人数，便于后续分析。

一些细节补充：从学校系统导出的数据按理说所有格式应该完全相同，但是为了提高程序的健壮性，各个字段所在的列，可以通过find来进行查找是否有对应字段，有的话再把该单元格作为range对象，找到其range.column
为了代码的可读性强，把几个功能拆开写，通过主程序来调用子程序。

源代码

Option Explicit
Sub 统计()
    Dim t
    t = Timer()
    '记录当前时间
 
    Call 是否建立工作簿
    Call 统计不及格的成绩复制到新表
    Call 不及格项目进行汇总
    Call 处理汇总
    Call 数据透视表
    '调用子程序
    MsgBox "一共用时" & Timer() - t & "秒"
    
End Sub


Sub 是否建立工作簿()
    Dim i As Long, count1 As Long, count2 As Long
    Dim w As Worksheet
    Set w = ActiveSheet
    count1 = 0: count2 = 0
    '判断是否存在挂科汇总学分这个工作簿
    w.UsedRange.Value = w.UsedRange.Value
    '将所有数据仅保存为值，防止文本，数字混在一起影响汇总
    For Each w In Worksheets
        If w.name = "所有挂科数据" Then
            count1 = count1 + 1
        ElseIf w.name = "挂科汇总学分" Then
            count2 = count2 + 1
        End If
    Next w
    '记录是否存在Sheet2，挂科汇总学分
    If count1 = 0 Then Worksheets.Add.name = "所有挂科数据"

    If count2 = 0 Then Worksheets.Add.name = "挂科汇总学分"
    '如果不存在，则建立新表
End Sub


Sub 统计不及格的成绩复制到新表()
    Dim i As Long, Grade As Long, ID As Long, course As Long
    'Grade,ID,course用来记录绩点，学号以及课程名所在的坐标
    Dim w1 As Worksheet, w2 As Worksheet
    Dim r1 As Range, r2 As Range, r3 As Range, r4 As Range
    Set w1 = Worksheets("Sheet1")
    Set w2 = Worksheets("所有挂科数据")
    Set r1 = w1.UsedRange
    Set r2 = w1.Cells.Find(what:="绩点")
    Set r3 = w1.Cells.Find(what:="学号")
    Set r4 = w1.Cells.Find(what:="课程")
    
    Grade = r2.Column
    ID = r3.Column
    course = r4.Column
    
    r1.Sort key1:=w1.Cells(1, ID), order1:=xlAscending, key2:=w1.Cells(1, course), _
                                   order2:=xlAscending, key3:=w1.Cells(1, Grade), _
                                   order3:=xlAscending, SortMethod:=xlPinYin, Header:=False
    '按照学号升序，确保一个人的成绩在一起
    '课程升序，一个人可能修了一门课多次，将这些课放在一起
    '绩点升序，确保同一门课，最大的一个数放在最后面，也即是说，判断是否挂科
    '看这一个数是否为0即可
    
    w1.Rows(1).Copy w2.Rows(1)
    '复制第一行表头到第二张表里做表头
    For i = 2 To w1.UsedRange.Rows.count
        If w1.Cells(i, ID) = w1.Cells(i + 1, ID) _
            And w1.Cells(i, course) <> w1.Cells(i + 1, course) _
            And w1.Cells(i, Grade) = 0 And w1.Cells(i, Grade) <> "" Then
        '判断是否为同一个人的成绩
        '如果该门课程和下一门课程不同
        '如果该门课程得分为0且成绩显示不为空
            w1.Rows(i).Copy w2.Rows(w2.UsedRange.Rows.count + 1)
            '将这一行复制粘贴到新表里面
        End If
    Next i
   
End Sub

Sub 不及格项目进行汇总()
    Dim i As Long, j As Long, k As String
    Dim ID As Long, r0 As Range, r1 As Range, r2 As Range, r3 As Range, r4 As Range, r5 As Range
    Dim count As Long, name As Long, credit As Long, course As Long, class As Long
    Dim w2 As Worksheet, w3 As Worksheet
    
    Set w2 = Worksheets("所有挂科数据"): Set w3 = Worksheets("挂科汇总学分")
    '定义好我们所需要的工作簿名称

    Set r0 = w2.UsedRange: Set r1 = w2.Cells.Find(what:="学号")
    Set r2 = w2.Cells.Find(what:="姓名"): Set r3 = w2.Cells.Find(what:="课程")
    Set r4 = w2.Cells.Find(what:="学分"): Set r5 = w2.Cells.Find(what:="班级")
    
    ID = r1.Column: name = r2.Column
    course = r3.Column: credit = r4.Column: class = r5.Column
    '设置这个用于找到这一列
    
    count = 0: j = 2
    '再用来存放的一个新表，从2开始存数据
        For i = 2 To r0.Rows.count + r0.Row - 1
        '用来确定最后一行的位置
            If w2.Cells(i, ID) = w2.Cells(i + 1, ID) Then
                
                count = count + w2.Cells(i, credit).Value
                    
            Else
                '当不再是该同学时，把刚才的数据都写到新的表里面
                w3.Cells(j, 1) = w2.Cells(i, ID)
                w3.Cells(j, 2) = w2.Cells(i, class)
                w3.Cells(j, 3) = w2.Cells(i, name)
                w3.Cells(j, 4) = count + w2.Cells(i, credit).Value
                    
                '因为跳出判断时没有加上该同学最后一行，这里补上
                j = j + 1
                'j累加，用于存放下一个同学的数据
                count = 0
                '学分清零，用于下一个同学的使用
            End If
               
        Next i
        
        w3.Cells(1, 1) = "学号": w3.Cells(1, 2) = "班级": Cells(1, 3) = "姓名"
        w3.Cells(1, 4) = "学分": w3.Cells(1, 5) = "预警级别"
        '写点表头
End Sub

Sub 处理汇总()
    Dim w As Worksheet
    Dim r As Range
    Dim i As Long
    Set w = Worksheets("挂科汇总学分")
    Set r = w.UsedRange
    r.Sort key1:=w.Range("d1"), order1:=xlDescending, Header:=False
    '按学分降序排列
    For i = 2 To r.Rows.count
    '根据预警规则写判断语句
        If w.Cells(i, 4) >= 30 Then
            w.Cells(i, 5) = "红色预警"
            w.Cells(i, 6).Interior.Color = vbRed
        ElseIf w.Cells(i, 4) >= 16 And w.Cells(i, 4) < 30 Then
            w.Cells(i, 5) = "橙色预警"
            w.Cells(i, 6).Interior.Color = RGB(255, 97, 0)
        ElseIf w.Cells(i, 4) > 8 And w.Cells(i, 4) < 16 Then
            w.Cells(i, 5) = "黄色预警"
            w.Cells(i, 6).Interior.Color = vbYellow
        End If
        
    Next i

End Sub

Sub 数据透视表()
    Dim w As Worksheet
    Set w = Worksheets("挂科汇总学分")

    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "挂科汇总学分!R1C2:R213C3", Version:=6).CreatePivotTable TableDestination:= _
        "挂科汇总学分!R3C12", TableName:="数据透视表1", DefaultVersion:=6

    With w.PivotTables("数据透视表1").PivotFields("班级")
        .Orientation = xlRowField
        .Position = 1
    End With
    w.PivotTables("数据透视表1").AddDataField ActiveSheet.PivotTables("数据透视表1" _
        ).PivotFields("姓名"), "计数项:姓名", xlCount
    Range("M4").Select
    w.PivotTables("数据透视表1").PivotFields("班级").AutoSort xlDescending, _
        "计数项:姓名", ActiveSheet.PivotTables("数据透视表1").PivotColumnAxis.PivotLines(1), 1
End Sub