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
On Error GoTo ErrHandler
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
For Each vItem In dicSection.keys()
With wsData.UsedRange
.AutoFilter field:=1, Criteria1:=vItem
Set rScore = .Offset(1, 1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
For Each rCell In rScore
Score = rCell.Value
If Application.IsNumber(Score) Then
Rnk = WorksheetFunction.Rank(CDbl(Score), rScore)
rCell.Offset(, 1).Value = Rnk & GetOrdinalSuffixForRank(Rnk)
End If
Next rCell
.AutoFilter
End With
Next vItem
ErrHandler:
If Err <> 0 Then
wsData.AutoFilterMode = False
MsgBox "Error " & Err.Number & ":" & vbCrLf & vbCrLf & Err.Description, vbCritical, "Error"
End If
Application.ScreenUpdating = True
Set dicSection = Nothing
Set rScore = Nothing
Set rCell = Nothing
End Sub
Function GetOrdinalSuffixForRank(Rnk As Double) As String
Dim sSuffix As String
If Rnk Mod 100 >= 11 And Rnk Mod 100 <= 20 Then
sSuffix = "th"
Else
Select Case (Rnk Mod 10)
Case 1
sSuffix = "st"
Case 2
sSuffix = "nd"
Case 3
sSuffix = "rd"
Case Else
sSuffix = "th"
End Select
End If
GetOrdinalSuffixForRank = sSuffix
End Function
