20171104xlVBA各人各科进退

Sub 各班个人各科进步幅度()
    Dim dRank As Object
    Set dRank = CreateObject("Scripting.Dictionary")
    Dim dStd As Object
    Set dStd = CreateObject("Scripting.Dictionary")
    Dim dSbj As Object
    Set dSbj = CreateObject("Scripting.Dictionary")
    
    em = Array("月考2", "期中考")
    For n = LBound(em) To UBound(em) Step 1
        Set sht = ThisWorkbook.Worksheets("成绩表_" & em(n))
        With sht
            EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
            EndCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
            
            For i = 2 To EndRow
                Key = CStr(.Cells(i, 1).Value)
                dStd(Key) = Array(CStr(.Cells(i, 1).Value), CStr(.Cells(i, 2).Text), CStr(.Cells(i, 3).Text))
                For J = 1 To EndCol
                    If .Cells(1, J).Text Like "*排" Then
                        dSbj(.Cells(1, J).Text) = ""
                    End If
                    
                    Key = CStr(.Cells(i, 1).Value) & ";" & em(n) & .Cells(1, J).Text
                    'Debug.Print Key
                    dRank(Key) = .Cells(i, J).Value
                    
                Next J
            Next i
        End With
    Next n
    
    
    For Each K In dSbj.Keys
        Set sht = CreateSheet(ThisWorkbook, K & "_飞跃进步_我^_^了")
        With sht
            .Range("a1").Resize(1, 6).Value = Array("考号", "姓名", "班级", em(0), em(1), "进退")
            EndCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
            
            i = 1
            For Each std In dStd.Keys
                i = i + 1
                Ar = dStd(std)
                .Cells(i, 1).Value = Ar(0)
                .Cells(i, 2).Value = Ar(1)
                .Cells(i, 3).Value = Ar(2)
                
                Key = CStr(Ar(0)) & ";" & .Cells(1, 4).Text & Split(.Name, "_")(0)
                .Cells(i, 4).Value = dRank(Key)
                Key = CStr(Ar(0)) & ";" & .Cells(1, 5).Text & Split(.Name, "_")(0)
                .Cells(i, 5).Value = dRank(Key)
                .Cells(i, 6) = Val(.Cells(i, 4).Value) - Val(.Cells(i, 5).Value)
                
            Next std
            
            Sort_Rank .UsedRange, True
            .Columns.AutoFit
        End With
    Next K
    
    Set dSbj = Nothing
    Set dStd = Nothing
    Set dRank = Nothing
    
End Sub
Public Sub Sort_ClassRank(ByVal Rng As Range, Optional WithHeader As Boolean = True)
    With Rng
        .Sort _
            Key1:=Rng.Cells(1, 3), Order1:=xlAscending, _
            Key2:=Rng.Cells(1, 6), Order2:=xlDescending, _
            Header:=IIf(WithHeader, xlYes, xlNo), MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
    End With
End Sub
Public Sub Sort_Rank(ByVal Rng As Range, Optional WithHeader As Boolean = True)
    With Rng
        .Sort _
            Key1:=Rng.Cells(1, 6), Order1:=xlDescending, _
            Header:=IIf(WithHeader, xlYes, xlNo), MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
    End With
End Sub