Sub 比对两次成绩()    CreateAdvance "进退比较", "月考2", "期中考", "月考2", "月考3"End SubSub 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 SubPublic 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 ArrEnd FunctionPublic 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 WithEnd SubSub 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 SubPublic Sub SetBorders(ByVal Rng As Range)    With Rng.Borders        .LineStyle = xlContinuous        .ColorIndex = xlAutomatic        .TintAndShade = 0        .Weight = xlThin    End WithEnd SubPublic Sub SetCenters(ByVal Rng As Range)    With Rng        .HorizontalAlignment = xlCenter        .VerticalAlignment = xlCenter    End WithEnd Sub