Ranking Code Amendment With System Reserved Numbers -vba

Status
Not open for further replies.

kelly mort

Well-known Member
Joined
Apr 10, 2017
Messages
2,169
Office Version
  1. 2016
Platform
  1. 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
Code:
==================
Number        Rank
==================
98        2nd
96        3nd
94        5th
93        6th
70        8th 
=================
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.


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
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Ok, try this:
Note:
data in col A & D must be sort descending.

Code:
[FONT=Lucida Console][COLOR=Royalblue]Sub[/COLOR] a1113655a()
[I][COLOR=Dimgray]'https://www.mrexcel.com/forum/excel-questions/1113655-ranking-code-amendment-system-reserved-numbers-vba.html[/COLOR][/I]
[COLOR=Royalblue]Dim[/COLOR] i [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Long[/COLOR], z [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Long[/COLOR], n [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Long[/COLOR]
[COLOR=Royalblue]Dim[/COLOR] d [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Object[/COLOR], e [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Object[/COLOR], f [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Object[/COLOR]
[COLOR=Royalblue]Dim[/COLOR] ary, arz

ary = Application.Transpose(Range([COLOR=Darkcyan]"D2"[/COLOR], Cells(Rows.Count, [COLOR=Darkcyan]"D"[/COLOR]).[COLOR=Royalblue]End[/COLOR](xlUp)))
arz = Application.Transpose(Range([COLOR=Darkcyan]"A2"[/COLOR], Cells(Rows.Count, [COLOR=Darkcyan]"A"[/COLOR]).[COLOR=Royalblue]End[/COLOR](xlUp)))
n = Range([COLOR=Darkcyan]"A"[/COLOR] & Rows.Count).[COLOR=Royalblue]End[/COLOR](xlUp).Value

[COLOR=Royalblue]Set[/COLOR] d = CreateObject([COLOR=Darkcyan]"scripting.dictionary"[/COLOR])
    [COLOR=Royalblue]For[/COLOR] i = [COLOR=Brown]1[/COLOR] [COLOR=Royalblue]To[/COLOR] [COLOR=Royalblue]UBound[/COLOR](ary)
        d(ary(i)) = [COLOR=Royalblue]Empty[/COLOR]
    [COLOR=Royalblue]Next[/COLOR]

[COLOR=Royalblue]Set[/COLOR] e = CreateObject([COLOR=Darkcyan]"scripting.dictionary"[/COLOR])
    [COLOR=Royalblue]For[/COLOR] i = [COLOR=Brown]1[/COLOR] [COLOR=Royalblue]To[/COLOR] [COLOR=Royalblue]UBound[/COLOR](arz)
        e(arz(i)) = [COLOR=Royalblue]Empty[/COLOR]
    [COLOR=Royalblue]Next[/COLOR]

[COLOR=Royalblue]Set[/COLOR] f = CreateObject([COLOR=Darkcyan]"scripting.dictionary"[/COLOR])
z = [COLOR=Brown]1[/COLOR]
    [COLOR=Royalblue]For[/COLOR] i = ary([COLOR=Brown]1[/COLOR]) [COLOR=Royalblue]To[/COLOR] n [COLOR=Royalblue]Step[/COLOR] -[COLOR=Brown]1[/COLOR]
    
    [COLOR=Royalblue]If[/COLOR] d.Exists(i) [COLOR=Royalblue]And[/COLOR] [COLOR=Royalblue]Not[/COLOR] e.Exists(i) [COLOR=Royalblue]Then[/COLOR] z = z + [COLOR=Brown]1[/COLOR]
    
    [COLOR=Royalblue]If[/COLOR] e.Exists(i) [COLOR=Royalblue]Then[/COLOR] f(i) = z: z = z + [COLOR=Brown]1[/COLOR]
    [COLOR=Royalblue]Next[/COLOR]

Range([COLOR=Darkcyan]"B2"[/COLOR]).Resize(f.Count, [COLOR=Brown]1[/COLOR]) = Application.Transpose(Array(f.items))


[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]Sub[/COLOR][/FONT]

Result:
Excel 2013 32 bit
A
B
C
D
1
NumberRankInput
2
98​
2​
100​
3
96​
3​
95​
4
94​
5​
90​
5
93​
6​
6
70​
8​

<tbody>
</tbody>
Sheet: Sheet2

<tbody>
</tbody>
 
Upvote 0
Okay cool. However, I have a few concerns:

1. Is there a way to make the code work without sorting column A at all? Because it may be hard to get all my columns sorted that way from the original code I posted.

2. Can I hard code the input values into the code through the array instead of the range input?

3. Can I still add the "st, nd, th" to the ranks?

4. From the original posted code, the last column I am ranking takes the totals for all the previous columns. And in this case, using same input will negatively affect the result. So I will be glad if we can swap the input for new one when we reach the last column. So if I am adding say three columns into the last column for example, then I may use input like, 300, 295, 290 to rank the last column

Code:
Num1.   Num2.      Num3.     Total.      Rank1.     Rank2.    Rank3     RankTotal

In case I have a layout as the above
 
Upvote 0
1. How many columns of number do you have? Is it dynamic?
2. Does each column of number has different input?
3. Can you post an example? And explain in more detail using that example.
4. Could you explain in more detail what you mean by this?
So if I am adding say three columns into the last column for example, then I may use input like, 300, 295, 290 to rank the last column
 
Last edited:
Upvote 0
Code:
N1    N2    N3    N4    N5    N6    N7    N8    N9    N10    TOT    INP1    R1    R2    R3    R4    R5    RNK6    RNK7    RNK8    RNK9    RNK10    RNKTOT    INPUT2
98    92    86    80    74    68    62    56    50    44    710    100    2nd    3rd    4th    4th    4th    4th    4th    4th    4th    4th    4th    1000
96    90    84    78    72    66    60    54    48    42    690    95    3rd    4th    5th    5th    5th    5th    5th    5th    5th    5th    5th    950
94    80    66    52    38    24    50    45    30    40    519    90    5th    5th    6th    6th    6th    6th    6th    6th    6th    6th    6th    900
92    45    50    45    30    20    45    40    25    38    430         6th    6th    7th    7th    7th    7th    7th    7th    7th    7th    7th     
70    56    42    28    14    10    34    25    10    20    309         8th    7th    8th    8th    8th    8th    8th    8th    8th    8th    8th

This is how my data is layed out. N1 is in column D. And input 1 and 2 show the various examples I cited above.

Input 1 runs from column D to column M.

Then column N which takes the totals of D to M.

Then when we reach N, we now use the input 2.

I hope this is clear enough to get me solution.

The column number is static. Just as in the above dataset

Thanks again
 
Last edited:
Upvote 0
I can't read your table properly.

Could you post your sample data as table?

To copy a simple table from worksheet:
1. In your worksheet select the table/range
2. In the menu, select border icon > select All Borders > then copy.
3. Back to the thread > cilck Reply then Go Advance (in the reply window, make sure you DON'T click "Switch Editor to Source Mode")
4. Paste the table then clcik Submit Reply


A simple table would look like this (there are no column letter & row number):

NAMEID
MaysonA01
AmayaA03
CaydenA04

<tbody>
</tbody>

If you want, in Excel not in the thread, you can arrange/move the data then manually type the column letter & row number around the data, so the result is like this:

AB
1NAMEID
2MaysonA01
3AmayaA03
4CaydenA04

<tbody>
</tbody>
 
Upvote 0
Status
Not open for further replies.

Forum statistics

Threads
1,213,486
Messages
6,113,932
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top