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