20171104xlVBA进退比较

Sub 比对两次成绩()
    CreateAdvance "进退比较", "月考2", "期中考", "月考2", "月考3"
End Sub
Sub CreateAdvance(ByVal MainName As String, ByVal ShtName1 As String, ByVal ShtName2 As String _
    , ByVal ExamName1 As String, ByVal ExamName2 As String)
    Dim Ar, Br
    Dim sht As Worksheet
    Dim Arr() As Variant
    Dim dNo As Object
    Dim dRank As Object
    Dim dRow As Object
    Dim OneKey
    Dim Key As String

    Const START_COL As Long = 4
    Set sht = ThisWorkbook.Worksheets(MainName)
    Set dNo = CreateObject("Scripting.Dictionary")
    Set dRank = CreateObject("Scripting.Dictionary")
    Set dRow = CreateObject("Scripting.Dictionary")
    '获取成绩数组
    Ar = GetArray(ShtName1, 0, "A", "S")
    Br = GetArray(ShtName2, 0, "A", "S")
    '
    For i = LBound(Ar) + 1 To UBound(Ar) Step 1

        Key = CStr(Ar(i, 1))
        dNo(Key) = Array(Ar(i, 1), Ar(i, 2), Ar(i, 3)) '储存号 名 班 信息
        For J = LBound(Ar, 2) To UBound(Ar, 2)
            K = Key & ExamName1 & Ar(1, J) '创建关键字 学号 & 考试名称 & 科目/排名
            'Debug.Print K
            dRank(K) = Ar(i, J) '储存所有信息
        Next J
    Next i
    For i = LBound(Br) + 1 To UBound(Ar) Step 1
        Key = CStr(Br(i, 1))
        dNo(Key) = Array(Br(i, 1), Br(i, 2), Br(i, 3)) '储存号 名 班 信息
        For J = LBound(Br, 2) To UBound(Br, 2)
            K = Key & ExamName2 & Br(1, J) '创建关键字 学号 & 考试名称 & 科目/排名
            'Debug.Print K
            dRank(K) = Br(i, J) '储存所有信息
        Next J
    Next i

    '重定义合并成绩表数组  行数为学生人数+标题1行    列数为每科4列 只保留排名列所以/2
    ReDim Arr(1 To dNo.Count + 1, 1 To (UBound(Ar, 2) - START_COL + 1) / 2 * 4 + START_COL - 1)
    'Debug.Print UBound(Arr, 2)
    For J = 1 To START_COL - 1
        Arr(1, J) = Ar(1, J)
    Next J
    '编制新表头
    x = 0
    For J = START_COL To UBound(Ar, 2)
        If Ar(1, J) Like "*排*" Then
            x = x + 1
            y = (START_COL - 1) + (x - 1) * 4 + 1
            Arr(1, y) = ExamName1 & Ar(1, J)
            Arr(1, y + 1) = ExamName2 & Ar(1, J)
            Arr(1, y + 2) = Ar(1, J) & "进退幅度"
            Arr(1, y + 3) = Ar(1, J) & "进退排名"
        End If
    Next J

    '将字典中的学生信息赋值给数组
    i = 1
    For Each OneKey In dNo.Keys
        i = i + 1
        Ar = dNo(OneKey)
        Arr(i, 1) = CStr(Ar(0))
        Arr(i, 2) = Ar(1)
        Arr(i, 3) = Ar(2)
        For J = START_COL To UBound(Arr, 2)
            If Arr(1, J) Like "*排" Then
                Key = CStr(Arr(i, 1)) & Arr(1, J)
                'Debug.Print Key
                Arr(i, J) = dRank(Key)
            ElseIf Arr(1, J) Like "*幅度" Then
                Arr(i, J) = Val(Arr(i, J - 2)) - Val(Arr(i, J - 1))
            End If
        Next J
    Next OneKey

    '分班分科插入进退步幅的排名公式
    With sht
        .Cells.Clear
        Set Rng = .Cells(1, 1)
        Set Rng = Rng.Resize(UBound(Arr), UBound(Arr, 2))
        Rng.Value = Arr
        Sort_2003 Rng, True, True, 3
        Arr = Rng.Value
        For i = LBound(Arr) + 1 To UBound(Arr)
            Key = CStr(Arr(i, 3))
            If Not dRow.Exists(Key) Then
                Ar = Array(i, 0)
                dRow(Key) = Ar
            Else
                Ar = dRow(Key)
                Ar(1) = i
                dRow(Key) = Ar
            End If
        Next i

        For J = 1 To UBound(Arr, 2)
            If Arr(1, J) Like "*排名" Then
                For Each OneKey In dRow.Keys
                    Ar = dRow(OneKey)
                    StartRow = Ar(0)
                    EndRow = Ar(1)
                    Set OneRng = .Range(.Cells(StartRow, J), .Cells(EndRow, J))
                    AddRankFormula OneRng, StartRow, EndRow
                Next OneKey
            End If
        Next J

        '复制粘贴替换公式
        Arr = Rng.Value
        Rng.Value = Arr
        '格式调整
        Rng.Columns.AutoFit
        SetBorders Rng
        SetCenters Rng
    End With

    Set dNo = Nothing
    Set dRank = Nothing
    Set sht = Nothing
    Set Rng = Nothing

End Sub
Public Function GetArray(ByVal SheetName As String, ByVal HeadRow As Long, ByVal StartCol As String, ByVal EndCol As String) As Variant
    Dim sht As Worksheet
    Dim Rng As Range
    Dim Arr As Variant
    Set sht = ThisWorkbook.Worksheets(SheetName)
    With sht
        EndRow = .Cells(.Cells.Rows.Count, StartCol).End(xlUp).Row
        Set Rng = .Range(.Cells(HeadRow + 1, StartCol), .Cells(EndRow, EndCol))
        Arr = Rng.Value
        GetArray = Arr
    End With
    Set Rng = Nothing
    Set sht = Nothing
    Erase Arr
End Function
Public Sub Sort_2003(ByVal Rng As Range, Optional WithHeader As Boolean = True, Optional OrderByAscending As Boolean = True, Optional SortColumnNo As Long = 1)
    With Rng
        .Sort _
            Key1:=Rng.Cells(1, SortColumnNo), Order1:=IIf(OrderByAscending, xlAscending, xlDescending), _
            Header:=IIf(WithHeader, xlYes, xlNo), MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
    End With
End Sub
Sub AddRankFormula(ByVal Rng As Range, ByVal StartRow As Long, ByVal EndRow As Long)
    Rng.FormulaR1C1 = "=RANK(RC[-1],R" & StartRow & "C[-1]:R" & EndRow & "C[-1])"
End Sub
Public Sub SetBorders(ByVal Rng As Range)
    With Rng.Borders
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub
Public Sub SetCenters(ByVal Rng As Range)
    With Rng
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
End Sub