Custom Rank Function in VBA

[Dan7986]

So, I'm having some difficulty coming up with my own Rank Function in VBA. Here's what I'm trying to accomplish: Create a function that moves the teams up/down according to the ranking position of each team. For example:

Rank Position	Team name	Points	Wins	Defeats
1	Finstock	16	6	1
2	Droogs	6	3	2
3	RoxStars	6	2	1
4	Suspects	6	2	2

The rank of a team is determined by the amount of points they earn. If there is a tie between two teams in points, the rank is determined by wins. If there is a tie in both points and wins, then whom ever has the least amount of defeats gets the higher ranked position. There are nine teams in total. All I really need is as a result is which team is in the 1st position, 2nd position, ect.

 

[jimrward]

Vba is not required you can do it with an extra helper column you need to create a decimal value to rank on made up as follows (points) + (wins/100)+ ((100-defeats)/10000) so your helper valueS are
16.0699
6.0398
6.0299
6.0298
then Rank on these values

 

[The_Macrotect]

Using Jim's method, you can automate it with VBA like this:

Sub calc_rank()
Dim lastrow As Integer, x As Integer, y As Integer

lastrow = Cells(Rows.Count, "B").End(xlUp).Row
Columns("A").Insert

For x = 2 To lastrow
    Cells(x, 1).Value = Cells(x, 4).Value + (Cells(x, 5).Value / 100) + ((100 - Cells(x, 6).Value) / 10000)
Next x

Columns("A:F").Sort key1:=Range("A2"), _
order1:=xlDescending, Header:=xlYes

Columns("A").Delete

For y = 2 To lastrow
    Cells(y, 1).Value = y - 1
Next y

End Sub

 

[jimrward]

OR you can use your original data as a work area and use INDEX and MATCH to pull the ranked data into a presentation area using the ranking of 1,2,3,4 etc
i am on an iPad at the moment so will give you an example later time to self isolate on my bike

 

[Dan7986]

What I'm looking for is a custom function to tell me the team name. I want to be able to retrieve the information from another sheet that has all the match scores. For example, this table is in my worksheet labeled Matches (2020):

Match	Team Name	Points
1	Finstock	2
1	Droogs	0
2	RoxStars	2
2	Suspects	0
3	Finstock	2
3	RoxStars	0

On my other worksheet, I have this table:

Rank	Team Name	Points	Wins	Defeats
1		0	0	0
2		0	0	0
3		0	0	0
4		0	0	0

The columns Points, Wins, and Defeats all have functions to search for the information from table 1 based on which Team Name I have in the blank cells in table 2. The reason why I want it this way is because when a team moves up or down in the ranks, I want it to be automated based on the information from table 1.

 

[Sulprobil]

You can have ties.

sbRankPointsWinsDefeats.xlsm
	A	B	C	D	E	F	G	H	I	J	K
1	Input						Output
2	Rank Position	Team name	Points	Wins	Defeats		Rank Position	Team name	Points	Wins	Defeats
3	1	Droogs	6	3	2		1	Finstock	16	6	1
4	2	Finstock	16	6	1		2	Droogs	6	3	2
5	3	RoxStars	6	2	1		3	RoxStars	6	2	1
6	4	Suspects	6	2	2		4	Suspects	6	2	2
Sheet1

Option Explicit

Sub sbRankPointsWinsDefeats(rInput As Range, rOutput As Range)
'Ranks input like
'Team name Points Wins Defeats
'Droogs         6    3       2
'Suspects       6    2       2
'Finstock      16    6       1
'RoxStars       6    2       1
'with rOutput set to upper left output cell as output
'Rank Position Team name Points Wins Defeats
'            1 Finstock      16    6       1
'            2 Droogs         6    3       2
'            3 RoxStars       6    2       1
'            4 Suspects       6    2       2
Dim i As Long, v As Variant
v = rInput
rOutput.Offset(0, 0).Resize(rInput.Rows.Count + 1, rInput.Columns.Count + 1).ClearContents
rOutput.Offset(0, 1).Resize(rInput.Rows.Count, rInput.Columns.Count) = v
rOutput = "Rank Position"
With Sheets(rOutput.Parent.Name).Sort
    .SortFields.Clear
    .SortFields.Add Key:=rOutput.Offset(1, 2).Resize(rInput.Rows.Count - 1, 1), Order:=xlDescending
    .SortFields.Add Key:=rOutput.Offset(1, 3).Resize(rInput.Rows.Count - 1, 1), Order:=xlDescending
    .SortFields.Add Key:=rOutput.Offset(1, 4).Resize(rInput.Rows.Count - 1, 1), Order:=xlAscending
    .SetRange rOutput.Offset(0, 1).Resize(rInput.Rows.Count, rInput.Columns.Count)
    .Header = xlYes
    .Apply
End With
rOutput.Offset(1, 0) = 1
For i = 2 To rInput.Rows.Count - 1
    If rOutput.Offset(i, 2) = rOutput.Offset(i - 1, 2) _
        And rOutput.Offset(i, 3) = rOutput.Offset(i - 1, 3) _
        And rOutput.Offset(i, 4) = rOutput.Offset(i - 1, 4) Then
        rOutput.Offset(i, 0) = rOutput.Offset(i - 1, 0) 'Tie with previous rank
    Else
        rOutput.Offset(i, 0) = i
    End If
Next i
End Sub

Sub RankIt()
Call sbRankPointsWinsDefeats(Range(Range("B2"), Range("B2").End(xlToRight).End(xlDown)), Range("G2"))
End Sub

 

[Dan7986]

OR you can use your original data as a work area and use INDEX and MATCH to pull the ranked data into a presentation area using the ranking of 1,2,3,4 etc
i am on an iPad at the moment so will give you an example later time to self isolate on my bike

That gives me the rank number. I'm looking for the team name that is ranked 1st, 2nd, 3rd. To fully understand what I'm looking for. I have the 1 in cell B2, 2 in cell B3, 3 in B4, ect. I want a function/formula (like INDEX and MATCH) to answer in C2: Which team is in 1st? Then I autofill the entire range.

 

[jimrward]

ok see what you can make of the following this is your work area

Book1
	A	B	C	D	E	F
1	Team name	Points	Wins	Defeats	Helper	Rank
2	Finstock	16	6	1	16.0699	1
3	Droogs	6	3	2	6.0398	2
4	RoxStars	6	2	1	6.0299	3
5	Suspects	6	2	2	6.0298	4
Sheet1

Cell Formulas
Range	Formula
E2:E5	E2	=B2+(C2/100)+((100-D2)/10000)
F2:F5	F2	=RANK(E2,$E$2:$E$5)

next here is your leader board which looks up the rank in the above and uses that reference to fill in the other bits, try copying to a test worksheet and play with the numbers in the above and see the leader board change dynamically

Book1
	A	B	C	D	E
12	LeaderBoard	TeamName	Points	Wins	Defeats
13	1	Finstock	16	6	1
14	2	Droogs	6	3	2
15	3	RoxStars	6	2	1
16	4	Suspects	6	2	2
Sheet1

Note I had both of the sets of data on the same worksheet

 

[Dan7986]

I'm afraid no one is understanding what I'm looking for. Here is what I have so far with my custom rank function. I know For j = Out1 to Out9 loop doesn't work but I'm not sure how to state it any other way except for writing every possibility, which is over 300,000 different possibilities.

Function FactionRank(Table As Range, Rank As Variant)
Fin = "The Finstock Exchange"
Droog = "The Burning Droogs"
RS = "RoxStars"
US = "The Usual Suspects"

For i = 1 To Table.Rows.Count
    If Table.Cells(i, 4) = Fin Then
        Out1 = Out1 + Table.Cells(i, 24)
        If Table.Cells(i, 21) = "Winner" Then
            Win1 = Win1 + 1
        Else
            Def1 = Def1 + 1
        End If
    End If
    If Table.Cells(i, 4) = Droog Then
        Out2 = Out2 + Table.Cells(i, 24)
        If Table.Cells(i, 21) = "Winner" Then
            Win2 = Win2 + 1
        Else
            Def2 = Def2 + 1
        End If
    End If
    If Table.Cells(i, 4) = RS Then
        Out3 = Out3 + Table.Cells(i, 24)
        If Table.Cells(i, 21) = "Winner" Then
            Win3 = Win3 + 1
        Else
            Def3 = Def3 + 1
        End If
    End If
    If Table.Cells(i, 4) = US Then
        Out4 = Out4 + Table.Cells(i, 24)
        If Table.Cells(i, 21) = "Winner" Then
            Win4 = Win4 + 1
        Else
            Def4 = Def4 + 1
        End If
    End If

For j = Out1 to Out9
   If Out1 > j Then
      
   End if
Next j

If Rank = 1 Then
    'cnt= highest ranked team
End If

If Rank = 2 Then
    'cnt= 2nd highest ranked team
End If

If Rank = 3 Then
    'cnt= 3rd highest ranked team
End If

If Rank = 4 Then
    'cnt= 4th highest ranked team
End If

FactionRank = cnt
End Function

 

[Sulprobil]

Input example:

sbMatchListToRankTable.xlsm
	A	B	C
1	Match	Team Name	Points
2	1	Finstock	2
3	1	Droogs	0
4	2	RoxStars	2
5	2	Suspects	0
6	3	Finstock	2
7	3	RoxStars	0
8	4	Finstock	2
9	4	Suspects	0
10	5	Finstock	2
11	5	Loosers	0
12	6	Finstock	2
13	6	Loosers	0
14	7	Finstock	2
15	7	Loosers	0
16	8	Finstock	0
17	8	RoxStars	2
18	9	Suspects	2
19	9	Loosers	0
20	10	Suspects	2
21	10	Droogs	0
22	11	Droogs	2
23	11	Loosers	0
24	12	Droogs	2
25	12	Loosers	0
26	13	Droogs	2
27	13	Loosers	0
Input

Output:

sbMatchListToRankTable.xlsm
	A	B	C	D	E
1	Rank	Team Name	Points	Wins	Defeats
2	1	Finstock	12	6	1
3	2	Droogs	6	3	2
4	3	RoxStars	4	2	1
5	4	Suspects	4	2	2
6	5	Loosers	0	0	7
Output

Cell Formulas
Range	Formula
A1:E6	A1	=sbMatchListToRankTable(Input!A1:C27)
Press CTRL+SHIFT+ENTER to enter array formulas.

The code:

Option Explicit

Enum Input_Columns
    icMatch = 1
    icTeamName
    icPoints
End Enum

Enum Output_Columns
    ocLBound = 0
    ocRank = 1
    ocTeamName
    ocPoints
    ocWins
    ocDefeats
    ocUBound
End Enum

Function sbMatchListToRankTable(rInput As Range) As Variant
'Takes an input list of matches and creates an output like
'Rank Position Team name Points Wins Defeats
'            1 Finstock      16    6       1
'            2 Droogs         6    3       2
'            3 RoxStars       6    2       1
'            4 Suspects       6    2       2
'You need to array-enter (enter with CTRL + ALT + F9) this function
'into a range of 5 columns and a sufficient number of rows.
Dim i As Long
Dim bLowerRank As Boolean
Dim dPointsCurrent As Double, dPointsPrevious As Double
Dim lMatchCurrent As Long, lMatchPrevious As Long
Dim sTeamNameCurrent As String, sTeamNamePrevious As String
Dim v As Variant, vR As Variant, vC As Variant, vP As Variant
Dim oRank As Object, oPoints As Object, oWins As Object, oDefeats As Object
Set oRank = CreateObject("Scripting.Dictionary")
Set oPoints = CreateObject("Scripting.Dictionary")
Set oWins = CreateObject("Scripting.Dictionary")
Set oDefeats = CreateObject("Scripting.Dictionary")
lMatchPrevious = 0
For i = 2 To rInput.Rows.Count
    sTeamNameCurrent = rInput.Cells(i, icTeamName)
    dPointsCurrent = rInput.Cells(i, icPoints)
    oPoints(sTeamNameCurrent) = oPoints(sTeamNameCurrent) + dPointsCurrent
    lMatchCurrent = rInput.Cells(i, icMatch)
    If lMatchCurrent = lMatchPrevious Then
        If dPointsPrevious > dPointsCurrent Then
            oWins(sTeamNamePrevious) = oWins(sTeamNamePrevious) + 1
            oDefeats(sTeamNameCurrent) = oDefeats(sTeamNameCurrent) + 1
        ElseIf dPointsPrevious < dPointsCurrent Then
            oWins(sTeamNameCurrent) = oWins(sTeamNameCurrent) + 1
            oDefeats(sTeamNamePrevious) = oDefeats(sTeamNamePrevious) + 1
        Else
            'No dealing with ties
        End If
    Else
        dPointsPrevious = dPointsCurrent
        lMatchPrevious = lMatchCurrent
        sTeamNamePrevious = sTeamNameCurrent
    End If
Next i
i = 1
For Each v In oPoints.keys
    If i = 1 Then
        oRank("First") = v
        oRank(v) = "None"
    Else
        vC = "First"
        vP = vC
        bLowerRank = True
        If (oPoints(v) > oPoints(oRank(vC))) Or _
            (oPoints(v) = oPoints(oRank(vC)) And oWins(v) > oWins(oRank(vC))) Or _
            (oPoints(v) = oPoints(oRank(vC)) And oWins(v) = oWins(oRank(vC)) And oDefeats(v) < oDefeats(oRank(vC))) Then
            bLowerRank = False
        End If
        Do While bLowerRank
            vP = vC
            vC = oRank(vC)
            If oRank(vC) = "None" Then Exit Do
            bLowerRank = True
            If (oPoints(v) > oPoints(oRank(vC))) Or _
                (oPoints(v) = oPoints(oRank(vC)) And oWins(v) > oWins(oRank(vC))) Or _
                (oPoints(v) = oPoints(oRank(vC)) And oWins(v) = oWins(oRank(vC)) And oDefeats(v) < oDefeats(oRank(vC))) Then
                bLowerRank = False
            End If
        Loop
        If bLowerRank Then
            oRank(vC) = v
            oRank(v) = "None"
        Else
            oRank(v) = oRank(vC)
            oRank(vC) = v
        End If
    End If
    i = i + 1
Next v
ReDim vR(1 To oPoints.Count + 1, ocLBound + 1 To ocUBound - 1) As Variant
ReDim vR(1 To Application.Caller.Rows.Count, ocLBound + 1 To ocUBound - 1) As Variant
vR(1, ocRank) = "Rank"
vR(1, ocTeamName) = "Team Name"
vR(1, ocPoints) = "Points"
vR(1, ocWins) = "Wins"
vR(1, ocDefeats) = "Defeats"
i = 2
vP = "First"
v = oRank(vP)
Do While v <> "None"
    If vP <> "First" Then
        If oPoints(v) = oPoints(vP) And oWins(v) = oWins(vP) And oDefeats(v) = oDefeats(vP) Then
            vR(i, ocRank) = vR(i - 1, ocRank)
        Else
            vR(i, ocRank) = i - 1
        End If
    Else
        vR(i, ocRank) = i - 1
    End If
    vR(i, ocTeamName) = v
    vR(i, ocPoints) = oPoints(v)
    vR(i, ocWins) = oWins(v)
    vR(i, ocDefeats) = oDefeats(v)
    i = i + 1
    vP = v
    v = oRank(v)
Loop
Do While i <= Application.Caller.Rows.Count
    vR(i, ocRank) = ""
    vR(i, ocTeamName) = ""
    vR(i, ocPoints) = ""
    vR(i, ocWins) = ""
    vR(i, ocDefeats) = ""
    i = i + 1
Loop
sbMatchListToRankTable = vR
End Function