Rank in Vba with criteria

[kelly mort]

I have this table layout

Section Score Rank
A 34 2
B 45 1
C 23 1
A 46 1




Now I am looking for a vba code to rank and show the out as I have under the rank column based on the section. I can do this with a formula but I need the vba code for it to speed up things small I think.


Thanks in advance
Kelly

 

[kelly mort]

I am starting my loop as:

For i = 2 To 12

Which lines do I need to alter?

It's throwing some error "No cells were found"

Then highlights the line :

Set rScore = .......

 

[Domenic]

Try the following instead...

Option Explicit

Sub RankScoresBySection()


    Dim dicSection As Object
    Dim vItem As Variant
    Dim wsData As Worksheet
    Dim vSection As Variant
    Dim rScore As Range
    Dim rCell As Range
    Dim Score As Variant
    Dim Rnk As Double
    Dim LastRow As Long
    Dim i As Long
    
    Application.ScreenUpdating = False
    
    Set wsData = ActiveSheet
    
    With wsData
        If .FilterMode Then .ShowAllData
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    
    If LastRow > 1 Then
        'Data exists
    Else
        MsgBox "No data exists!", vbExclamation
        Exit Sub
    End If
    
    Set dicSection = CreateObject("Scripting.Dictionary")
    dicSection.CompareMode = 1 'vbTextCompare
    
    vSection = wsData.Range("A1:A" & LastRow).Value
    
    For i = LBound(vSection) + 1 To UBound(vSection)
        If Not dicSection.Exists(vSection(i, 1)) Then
            dicSection(vSection(i, 1)) = ""
        End If
    Next i
    
    On Error Resume Next
    For Each vItem In dicSection.keys()
        With wsData.UsedRange
            .AutoFilter field:=1, Criteria1:=vItem
            For i = 0 To 2
                .AutoFilter field:=i + 2, Criteria1:=">0"
                Set rScore = .Offset(1, i + 1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
                If Err = 0 Then
                    For Each rCell In rScore
                        Score = rCell.Value
                        If Application.IsNumber(Score) Then
                            Rnk = WorksheetFunction.Rank(CDbl(Score), rScore)
                            rCell.Offset(, 3).Value = Rnk & GetOrdinalSuffixForRank(Rnk)
                        End If
                    Next rCell
                Else
                    Err.Clear
                End If
                .AutoFilter field:=i + 2
            Next i
            .AutoFilter
        End With
    Next vItem
    On Error GoTo 0
    
    Application.ScreenUpdating = True
    
    Set dicSection = Nothing
    Set rScore = Nothing
    Set rCell = Nothing
    
End Sub

Hope this helps!