[RESOLVED] Rank - VBA

[DKenny]

Try this

Sub TopTwo()
Dim rngData As Range
Dim asOutput() As String
Dim lRowNum As Long
Dim bOn2ndRow As Boolean
Dim wksNewSheet As Worksheet
 
    'You will need to change this line to correctly refer
    'to your data range (excluding the header row)
    Set rngData = ThisWorkbook.Worksheets(1).Range("A2:B10")
    
    'Initialize the array
    ReDim asOutput(0 To 1, 0 To 0)
    
    
    With rngData
        'Sort by Rank and then name
        .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, _
            Key2:=.Cells(1, 2), Order2:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
            DataOption2:=xlSortNormal
            
        
        'load the first record into the array
        asOutput(0, 0) = .Cells(1, 1).Value
        asOutput(1, 0) = .Cells(1, 2).Value
        'note that we are next loading a "2nd" row
        bOn2ndRow = True
        
        'Loop through the rest of the rows
        For lRowNum = 2 To .Rows.Count
            
            'If the Next rank is different from the last recorded...
            If .Cells(lRowNum, 1).Value <> asOutput(0, UBound(asOutput, 2)) Then
                
                '...Add a new record to the array
                ReDim Preserve asOutput(0 To 1, UBound(asOutput, 2) + 1)
                asOutput(0, UBound(asOutput, 2)) = .Cells(lRowNum, 1)
                asOutput(1, UBound(asOutput, 2)) = .Cells(lRowNum, 2)
                
                '...and note that we are next loading a "2nd" row
                bOn2ndRow = True
                            
            'If we are loading a "2nd" Row
            ElseIf bOn2ndRow Then
                
                '...Add a new record to the array
                ReDim Preserve asOutput(0 To 1, UBound(asOutput, 2) + 1)
                asOutput(0, UBound(asOutput, 2)) = .Cells(lRowNum, 1)
                asOutput(1, UBound(asOutput, 2)) = .Cells(lRowNum, 2)
                
                '...and note that we are next loading a "1st" row
                bOn2ndRow = False
            End If
        Next lRowNum
    End With
    
    'Add a new Sheet
    Set wksNewSheet = ThisWorkbook.Worksheets.Add
    
    With wksNewSheet.Range("A1")
        'Write the Headers
        .Value = "Rank"
        .Offset(0, 1).Value = "Name"
        
        'Copy the array onto the new sheet
        For lRowNum = 0 To UBound(asOutput, 2)
            .Offset(1 + lRowNum, 0) = asOutput(0, lRowNum)
            .Offset(1 + lRowNum, 1) = asOutput(1, lRowNum)
        Next lRowNum
    End With
    
    'Clear Object variables
    Set wksNewSheet = Nothing
End Sub