Improving Leader-board Function in VBA

[Dan7986]

Hey all. So, currently I created a leader-board function for a sport's league to determine which team is in 1st place, 2nd place, ect. The drawbacks is that it works for now and doesn't allow any for any new teams without writing more code and it is a long code (this version is a more condensed from the previous one). Can anyone, at the very least, help me to make it more condensed and/or make it to were new teams can be added without writing more code?

The result with the current code looks like this combined with the two tables and the variant is the rank number. The MatchTable is a table that has all the match information and the FactionTable is a range with all the Team Names:

Rank No.	Team Name
1	Team 1
2	Team 2
3	Team 3
4	Team 4
5	Team 5
6	Team 6
7	Team 7
8	Team 8
9	Team 9

You can change anything about the code as long as the result is the same the above table illustrates and it includes any new teams that might be created in the future. Thanks in advance

Function LeaderBoard(MatchTable As Range, FactionTable As Range, Rank As Variant)
Val1 = 0
Val2 = 0
Val3 = 0
Val4 = 0
Val5 = 0
Val6 = 0
Val7 = 0
Val8 = 0
Val9 = 0
Var1 = 0
Var2 = 0
Var3 = 0
Var4 = 0
Var5 = 0
Var6 = 0

Fin = "The Finstock Exchange"
SW = "SWAG"
Den = "The Den"
Droog = "The Burning Droogs"
RS = "RoxStars"
US = "The Usual Suspects"
Dun = "The Dungeon"
QM = "The Quirky Mercs"
Kor = "Korruption"

For i = 1 To MatchTable.Rows.Count
    If MatchTable.Cells(i, 4) = Fin Then
        Out1 = Out1 + MatchTable.Cells(i, 24)
        If MatchTable.Cells(i, 21) = "Winner" Then
            Win1 = Win1 + 1 + (MatchTable.Cells(i, 23) / 1000)
        Else
            Def1 = Def1 + 1
        End If
    End If
    
    If MatchTable.Cells(i, 4) = SW Then
        Out2 = Out2 + MatchTable.Cells(i, 24)
        If MatchTable.Cells(i, 21) = "Winner" Then
            Win2 = Win2 + 1 + (MatchTable.Cells(i, 23) / 1000)
        Else
            Def2 = Def2 + 1
        End If
    End If
    
    If MatchTable.Cells(i, 4) = Den Then
        Out3 = Out3 + MatchTable.Cells(i, 24)
        If MatchTable.Cells(i, 21) = "Winner" Then
            Win3 = Win3 + 1 + (MatchTable.Cells(i, 23) / 1000)
        Else
            Def3 = Def3 + 1
        End If
    End If
    
    If MatchTable.Cells(i, 4) = Droog Then
        Out4 = Out4 + MatchTable.Cells(i, 24)
        If MatchTable.Cells(i, 21) = "Winner" Then
            Win4 = Win4 + 1 + (MatchTable.Cells(i, 23) / 1000)
        Else
            Def4 = Def4 + 1
        End If
    End If
    
    If MatchTable.Cells(i, 4) = RS Then
        Out5 = Out5 + MatchTable.Cells(i, 24)
        If MatchTable.Cells(i, 21) = "Winner" Then
            Win5 = Win5 + 1 + (MatchTable.Cells(i, 23) / 1000)
        Else
            Def5 = Def5 + 1
        End If
    End If
    
    If MatchTable.Cells(i, 4) = US Then
        Out6 = Out6 + MatchTable.Cells(i, 24)
        If MatchTable.Cells(i, 21) = "Winner" Then
            Win6 = Win6 + 1 + (MatchTable.Cells(i, 23) / 1000)
        Else
            Def6 = Def6 + 1
        End If
    End If
    
    If MatchTable.Cells(i, 4) = Dun Then
        Out7 = Out7 + MatchTable.Cells(i, 24)
        If MatchTable.Cells(i, 21) = "Winner" Then
            Win7 = Win7 + 1 + (MatchTable.Cells(i, 23) / 1000)
        Else
            Def7 = Def7 + 1
        End If
    End If
    
    If MatchTable.Cells(i, 4) = QM Then
        Out8 = Out8 + MatchTable.Cells(i, 24)
        If MatchTable.Cells(i, 21) = "Winner" Then
            Win8 = Win8 + 1 + (MatchTable.Cells(i, 23) / 1000)
        Else
            Def8 = Def8 + 1
        End If
    End If
    
    If MatchTable.Cells(i, 4) = Kor Then
        Out9 = Out9 + MatchTable.Cells(i, 24)
        If MatchTable.Cells(i, 21) = "Winner" Then
            Win9 = Win9 + 1 + (MatchTable.Cells(i, 23) / 1000)
        Else
            Def9 = Def9 + 1
        End If
        
    End If
    
Next i

'Fin
Val1 = Out1 + (Win1 / 100) + ((100 - Def1) / 10000)
'SWAG
Val2 = Out2 + (Win2 / 100) + ((100 - Def2) / 10000)
'Den
Val3 = Out3 + (Win3 / 100) + ((100 - Def3) / 10000)
'Droogs
Val4 = Out4 + (Win4 / 100) + ((100 - Def4) / 10000)
'RoxStars
Val5 = Out5 + (Win5 / 100) + ((100 - Def5) / 10000)
'Suspects
Val6 = Out6 + (Win6 / 100) + ((100 - Def6) / 10000)
'Dungeon
Val7 = Out7 + (Win7 / 100) + ((100 - Def7) / 10000)
'Mercs
Val8 = Out8 + (Win8 / 100) + ((100 - Def8) / 10000)
'Korrupt
Val9 = Out9 + (Win9 / 100) + ((100 - Def9) / 10000)

High = WorksheetFunction.Max(Val1, Val2, Val3, Val4, Val5, Val6, Val7, Val8, Val9)
Low = WorksheetFunction.Min(Val1, Val2, Val3, Val4, Val5, Val6, Val7, Val8, Val9)
Middle = WorksheetFunction.Median(Val1, Val2, Val3, Val4, Val5, Val6, Val7, Val8, Val9)

For s = 1 To FactionTable.Rows.Count
    Value = 0
    Out = 0
    Win = 0
    Def = 0
    For i = 1 To MatchTable.Rows.Count
        If MatchTable.Cells(i, 4) = FactionTable.Cells(s, 1) Then
            Out = Out + MatchTable.Cells(i, 24)
            If MatchTable.Cells(i, 21) = "Winner" Then
                Win = Win + 1 + (MatchTable.Cells(i, 23) / 1000)
            Else
                Def = Def + 1
            End If
        End If
    Next i
    
    Value = Out + (Win / 100) + ((100 - Def) / 10000)
    If Value = High Then
        If Rank = 1 Then
            cnt = FactionTable.Cells(s, 1)
        End If
    End If
    
    If Value = Low Then
        If Rank = 9 Then
            cnt = FactionTable.Cells(s, 1)
        End If
    End If
    
    If Value = Middle Then
        If Rank = 5 Then
            cnt = FactionTable.Cells(s, 1)
        End If
    End If

    If Value < High And Value > Middle Then
        If Value > Var3 Then
            If Var3 = Var1 Then
                Var3 = Value
            End If
        End If
        
        If Value <> Var3 Then
            If Var1 = Var2 Then
                Var1 = Value
            Else
                If Value <> Var1 And Var3 Then
                    Var2 = Value
                End If
            End If
        End If
    End If
    
    If Value < Middle And Value > Low Then
        If Value > Var6 Then
            If Var6 = Var4 Then
                Var6 = Value
            End If
        End If
        
        If Value <> Var6 Then
            If Var4 = Var5 Then
                Var4 = Value
            Else
                If Value <> Var4 And Var6 Then
                    Var5 = Value
                End If
            End If
        End If
    End If
Next s

High2 = WorksheetFunction.Max(Var1, Var2, Var3)
Low2 = WorksheetFunction.Min(Var1, Var2, Var3)
Mid2 = WorksheetFunction.Median(Var1, Var2, Var3)
High3 = WorksheetFunction.Max(Var4, Var5, Var6)
Low3 = WorksheetFunction.Min(Var4, Var5, Var6)
Mid3 = WorksheetFunction.Median(Var4, Var5, Var6)

For s = 1 To FactionTable.Rows.Count
    Value = 0
    Out = 0
    Win = 0
    Def = 0
    
    For i = 1 To MatchTable.Rows.Count
        If MatchTable.Cells(i, 4) = FactionTable.Cells(s, 1) Then
            Out = Out + MatchTable.Cells(i, 24)
            If MatchTable.Cells(i, 21) = "Winner" Then
                Win = Win + 1 + (MatchTable.Cells(i, 23) / 1000)
            Else
                Def = Def + 1
            End If
        End If
    Next i

 

[GWteB]

I have only worked on the first part of your code. Regarding the second part, I'm not sure because I don't know what your MatchTable looks like.
In this example sheet the address of the FactionTable range is "A2:B10". My code is based on this assumption.

Book1
	A	B
1	Rank No.	Team Name
2	1	The Finstock Exchange
3	2	SWAG
4	3	The Den
5	4	The Burning Droogs
6	5	RoxStars
7	6	The Usual Suspects
8	7	The Dungeon
9	8	The Quirky Mercs
10	9	Korruption
Sheet1

First part of the procedure could look like this. Note the "Option Base 1" and the "Enum Results". Both are needed in order for the procedure to work properly.

Option Explicit
Option Base 1

Private Enum Results
    Team = 1
    Out = 2
    Win = 3
    Def = 4
    Val = 5
End Enum

Public Sub LeaderBoard_r1(MatchTable As Range, FactionTable As Range, Rank As Variant)

    Dim vTeams()    As Variant
    Dim vVals()     As Variant
    Dim lTeamCount  As Long
    Dim i           As Long
    Dim n           As Long

    ' get number of teams
    lTeamCount = FactionTable.Rows.Count

    ' load those teams in an array
    ReDim vTeams(lTeamCount, Val)
    For i = 1 To lTeamCount
        vTeams(i, Team) = FactionTable.Columns(2).Cells(i)
    Next

    ' Get results per team
    For i = 1 To MatchTable.Rows.Count
        For n = 1 To lTeamCount
            If MatchTable.Cells(i, 4) = vTeams(n, Team) Then
                vTeams(n, Out) = vTeams(n, Out) + MatchTable.Cells(i, 24)
                If StrComp(MatchTable.Cells(i, 21), "winner", vbTextCompare) = 0 Then
                    vTeams(n, Win) = vTeams(n, Win) + 1 + (MatchTable.Cells(i, 23) / 1000)
                Else
                    vTeams(n, Def) = vTeams(n, Def) + 1
                End If
            End If
        Next n
    Next i

    ReDim vVals(lTeamCount)
    For n = 1 To lTeamCount
        vTeams(n, Val) = vTeams(n, Out) + (vTeams(n, Win) / 100) + ((100 - vTeams(n, Def)) / 10000)
        vVals(n) = vTeams(n, Val)
    Next n

    High = WorksheetFunction.Max(vVals)
    Low = WorksheetFunction.Min(vVals)
    Middle = WorksheetFunction.Median(vVals)

    ' ==============================
    ' the rest of your original code
    ' ==============================
'    For s = 1 To FactionTable.Rows.Count
'        Value = 0
'        Out = 0
'        Win = 0

End Sub

 

[Dan7986]

Your code works really well, even without seeing the MatchTable. With a few tweaks to the code, it can produce the results I'm looking for. I did have to add something at the end of it:

If Rank = 1 Then
   cnt= High
End if

If Rank = 5 Then
  cnt= Mid
End if

If Rank = 9 Then
  cnt = Low
End if

Doing it this way allows for only nine teams to be accounted for and it only gives the values for the 1st place, 5th place, and 9th (currently last) place teams and the other places being 0. The end result should display all the Team Names with B2 having the team with the highest points, B3 the team with the second highest points, B4 having the team with the third highest points, ect.

I've also included what the MatchTable looks like.

 

[GWteB]

Would like to help further but not willing to setup worksheets manually the way you have them. Kindly ask you posting both worksheets in this thread using XL2BB (see my signature) as well as the code you have so far.

 

[Dan7986]

Here is a link to my worksheet. I figured out how to rank all the vVals in descending order:

WorksheetFunctions.Large(vVals,Rank)

So, really all I need now is for the end result to give me the team name instead of the value number, and we're good to go.

Sorry it took a while to get back to you, but I've been working allot lately.

Thanks

 

[Dan7986]

I just cracked it. Thanks for the hard work to condense the code down

Function Test(FactionTable As Range, MatchTable As Range, Rank As Variant)

    Dim vTeams()    As Variant
    Dim vVals()     As Variant
    Dim lTeamCount  As Long
    Dim i           As Long
    Dim n           As Long
    Dim Team As Variant
    Dim Out As Variant
    Dim Win As Variant
    Dim Def As Variant
    Dim Val As Variant
    
    Team = 1
    Out = 2
    Win = 3
    Def = 4
    Val = 5

    ' get number of teams
    lTeamCount = FactionTable.Rows.Count

    ' load those teams in an array
    ReDim vTeams(lTeamCount, Val)
    For i = 1 To lTeamCount
        vTeams(i, Team) = FactionTable.Cells(i, 1)
    Next

    ' Get results per team
    For i = 1 To MatchTable.Rows.Count
        For n = 1 To lTeamCount
            If MatchTable.Cells(i, 4) = vTeams(n, Team) Then
                vTeams(n, Out) = vTeams(n, Out) + MatchTable.Cells(i, 25)
                If StrComp(MatchTable.Cells(i, 22), "winner", vbTextCompare) = 0 Then
                    vTeams(n, Win) = vTeams(n, Win) + 1 + (MatchTable.Cells(i, 24) / 1000)
                Else
                    vTeams(n, Def) = vTeams(n, Def) + 1
                End If
            End If
        Next n
    Next i

    ReDim vVals(lTeamCount)
    For n = 1 To lTeamCount
        vTeams(n, Val) = vTeams(n, Out) + (vTeams(n, Win) / 100) + ((100 - vTeams(n, Def)) / 10000)
        vVals(n) = vTeams(n, Val)
    Next n
    
    For n = 1 To lTeamCount
        If WorksheetFunction.Large(vVals, Rank) = vVals(n) Then
            cnt = vTeams(n, Team)
        End If
    Next n
    
    Test = cnt
End Function