Ranking the rows without sorting

[clark8529]

Hi,
I have a list of participants for a contest. As such, I need to rank the participants according to their respective scores from highest (1) to lowest (500).
The easiest way is definitely sorting the names by score from highest to lowest but I am not allowed to do that. My superior wants the list to maintain its originality while the names gets ranked. Can anyone suggest some help that uses VBA to code? A sample of the list looks like this:

Names	Score	Rank
Jason M.	34
Mark W.	12
Clark P.	50
Alex C.	98
Alexis Q.	93
Nathaniel A.	23
Lewis L.	45
James J.	78
Joseph G.	54
Jessie G.	32
Joe D.	34
John H.	53
Pepper M.	99
Nathalie M.	93

And the list goes on... Appreciate if anyone could help me with it.
I wanted VBA because this will not be only time I have to do this. So if there is a code to it, I can just use the code again the next time this task comes by.

[MickG]

Try this:-

Sub RK()
Dim Rng As Range, Dn As Range, n As Long, c As Long
Set Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
ReDim ray(1 To Application.Max(Rng))
For Each Dn In Rng
    ray(Dn.Value) = ray(Dn.Value) & IIf(ray(Dn.Value) = "", Dn.Address, "," & Dn.Address)
Next Dn
For n = UBound(ray) To 1 Step -1
    If ray(n) <> "" Then
        c = c + 1
        For Each Dn In Range(ray(n)).Areas
            Range(Dn.Address).Offset(, 1).Value = c
        Next Dn
    End If
Next n
End Sub

[mdmackillop]

By formula is simpler
=RANK(B2,$B$2:$B$501,0)

Using VBA

    Selection.Formula = "=RANK(" & Selection(1).Offset(, -1).Address(0, 0) & "," & Selection.Offset(, -1).Address(1, 1) & ",0)"

[SamT]

Add helper column. Fill series to bottom with numbers 1 to?

Sort by Score. Fill Rank column with series to bottom with numbers 1 to?

Sort by helper column, then delete helper column.

Coulda done it faster then typing this response. But I'm a slow typist

[mdmackillop]

This will show equal places as "2=" etc.

Option Explicit
Sub Ranks()
    Dim r As Range, c As Range
    Dim s As Long, i As Long, k As Long
    Dim FA As String


    Set r = Cells.Find("Score")
    Set r = Range(r(2), r(2).End(xlDown))
    s = Application.Max(r)
    i = 1
    For s = Application.Max(r) To 1 Step -1
        k = 0
        With r
            Set c = .Find(s, lookat:=xlWhole)
            If Not c Is Nothing Then
                FA = c.Address
                Do
                    k = k + 1
                    Set c = .FindNext(c)
                Loop Until c.Address = FA
                
                Set c = .Find(s, lookat:=xlWhole)
                FA = c.Address
                Do
                    If k > 1 Then
                        c.Offset(, 1) = i & "="
                    Else
                        c.Offset(, 1) = i
                    End If
                    Set c = .FindNext(c)
                Loop Until c.Address = FA
            End If
        End With
        i = i + k
    Next s
End Sub

[mancubus]

i use below in one of my projects...

Sub vbax_58943_rank_range()
    
    Dim rng As Range
    
    With Worksheets("Sheet1")
        Set rng = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
        rng.Offset(, 1).Value = Application.Rank(rng, rng)
    End With
End Sub

Application.Rank(rng, rng) or Application.Rank(rng, rng, 0) ranks in descending order

Application.Rank(rng, rng, 1) ranks in ascending order (third argument, the order, any nonzero value as per MS help)

[mdmackillop]

Sub vbax_58943_rank_range()

I like that idea. I keep forgetting where to find what I was previously working on.

[mancubus]

i don't remember where i first saw this, "naming the sub with the thread number". mr excel or excel forum.

[clark8529]

Thanks guys. The suggestions worked.
It helped a bunch on my work now.