kelly mort
Well-known Member
- Joined
- Apr 10, 2017
- Messages
- 2,169
- Office Version
- 2016
- Platform
- Windows
I want to set some numbers as system numbers to use against the ranking as done by the code below. Currently, I am using three numbers – 100, 95 and 90. In the future, I may reduce (say 2 numbers) or increase (say 5 or more numbers). And in each scenario, the aim is to make those numbers take the top-most ranks, should those numbers fail to appear in my data as I define the rules below. So these are the rules:
1. 100 is always ranked first. Which means that if there is no 100 in my data, then the highest number in my data is second but not first and run for numbers from 99 to 95 in my data
2. If there are no numbers from 99 to 95 in my data, then 95 is ranked second into the system, then numbers from 94 to 91 take from 4th downwards. But if there are say 98 and 96 in my data, then after systematically using the first rank for 100(system number), then we have 2nd for 98 and 3rd for 96. In this case, the next system number, 95, which by default was supposed to be 2nd, will now shift to the 4th rank. So here, the rank shift as there are more numbers in between.
3. If the highest ranked number in the point 2 above is 2nd, then, we assign 3rd to our system number 90. But if that is different, say 3rd, 4th etc, then we make the rank shift as described in point 2 above.
Sample of how I want my output look like
From the above, since there were no 100, 95 and 90 in my data, those ranks were absorbed by the system, 1st for 100, 4th for 95 and 7th for 90.
Thanks so much for your time and effort to help me out.
1. 100 is always ranked first. Which means that if there is no 100 in my data, then the highest number in my data is second but not first and run for numbers from 99 to 95 in my data
2. If there are no numbers from 99 to 95 in my data, then 95 is ranked second into the system, then numbers from 94 to 91 take from 4th downwards. But if there are say 98 and 96 in my data, then after systematically using the first rank for 100(system number), then we have 2nd for 98 and 3rd for 96. In this case, the next system number, 95, which by default was supposed to be 2nd, will now shift to the 4th rank. So here, the rank shift as there are more numbers in between.
3. If the highest ranked number in the point 2 above is 2nd, then, we assign 3rd to our system number 90. But if that is different, say 3rd, 4th etc, then we make the rank shift as described in point 2 above.
Sample of how I want my output look like
Code:
==================
Number Rank
==================
98 2nd
96 3nd
94 5th
93 6th
70 8th
=================Thanks so much for your time and effort to help me out.
Code:
Sub RankDynamic()
Dim dicSection As Object, vItem As Variant, wsData As Worksheet, vSection As Variant, rScore As Range, _
rCell As Range, Score As Variant, Rnk As Double, LastRow&, iCol&
Application.ScreenUpdating = False
Set wsData = Sheets("Sheet1")
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 Resume Next
Set dicSection = CreateObject("Scripting.Dictionary")
dicSection.CompareMode = 1 'vbTextCompare
vSection = wsData.Range("C6:C" & 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:=3, Criteria1:=vItem
Set rScore = .Offset(1, 1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
For i = 2 To 12
For Each rCell In rScore.Offset(, i)
Score = rCell.Value
If Application.IsNumber(Score) Then
Rnk = WorksheetFunction.Rank(CDbl(Score), rScore.Offset(, i))
rCell.Offset(, 12).Value = Rnk & GetOrdinalSuffixForRank(Rnk)
End If
Next rCell
Next i
.AutoFilter
End With
Next vItem
Application.ScreenUpdating = True
Set dicSection = Nothing
Set rScore = Nothing
Set rCell = Nothing
End Sub
Function GetOrdinalSuffixForRank(Rnk As Double) As String
Dim sSuffix$
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
