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.