Option Explicit Public Rounds As Collection
Public Teams As Collection
Public Games As Collection
Public oTournament As clsTournament
Public lngNoofTeams As Long
Public lngNoOfRounds As Long
Public lngNoOfGames As Long
Public Const lngWhite As Long = 16777215
Public Const lngDark_Blue As Long = 10027008
Public Const lngLight_Blue As Long = 16711680
Public Const blnDeveloper As Boolean = False
Public Enum Os
ePlayed = 1
eWon
eDrew
eLost
eFor
eAgainst
ePoints
eGoalDifference
End Enum
Sub New_Tournament()
If MsgBox("Do you want to start a new tournament?" & vbCr & vbCr & _
"Warning: This will reset EVERYTHING and is irreversible", vbYesNo) = vbYes Then
How_Many_Teams lngNoofTeams
If lngNoofTeams > 0 Then
Initialise_Team_List
Application.ScreenUpdating = False
Create_Objects
Populate_Team_Names
Reset_Scores
Table_Construction
Application.ScreenUpdating = True
Else
MsgBox "Cancelled"
End If
End If
End Sub
Sub How_Many_Teams(ByRef lngNoofTeams As Long)
Dim vInput As Variant
Dim blnValid As Boolean
Do
vInput = InputBox("No. of teams? 2-32")
If IsNumeric(vInput) Then
vInput = Int(vInput)
If vInput >= 2 And vInput <= 32 Then blnValid = True
End If
Loop Until blnValid = True Or vInput = ""
If vInput <> "" Then lngNoofTeams = Val(vInput)
End Sub
Sub Initialise_Team_List()
Dim I As Long
Range("Team_Names").Offset(1).Resize(32).EntireRow.Hidden = False
If lngNoofTeams < 32 Then Range("Team_Names").Offset(lngNoofTeams + 1).Resize(32 - lngNoofTeams).EntireRow.Hidden = True
With Worksheets("Teams")
.Range("Team_Names").Offset(1).Resize(32).ClearContents
.Select
End With
For I = 1 To lngNoofTeams
Range("Team_Names").Offset(I) = "Team " & Chr(64 + I - ((I > 26) * 6))
Next
End Sub
Sub Get_No_Of_Teams()
lngNoofTeams = lngNoTeams()
lngNoOfRounds = lngNoRounds()
lngNoOfGames = lngNoGames()
End Sub
Sub Create_Objects()
Dim oRound As clsRound
Dim oGame As clsGame
Dim oTeam As clsTeam
Dim aoTeam() As clsTeam
Dim lngRound As Long
Dim lngGame As Long
Dim lngGameCount As Long
Dim lngTeam As Long
Dim blnTeamsEven As Boolean
Set oTournament = New clsTournament
Set Rounds = New Collection
Set Teams = New Collection
ReDim aoTeam(lngNoofTeams)
blnTeamsEven = (lngNoofTeams / 2 = Int(lngNoofTeams / 2)) ' True if number of teams is even
lngNoOfRounds = lngNoRounds() ' Calculate no of rounds
lngNoOfGames = lngNoGames() ' Calculate no of games per round
For lngTeam = 1 To lngNoofTeams ' Create all the Team objects, add them to Teams collection and retrieve names from Data sheet
Set oTeam = New clsTeam
Teams.Add oTeam
Set aoTeam(lngTeam) = oTeam
Next
Set oTournament.TeamAdd = Teams ' Add teams to Tournament Teams collection
For lngRound = 1 To lngNoOfRounds
Set oRound = New clsRound
Set Games = New Collection
Rounds.Add oRound
oRound.Name = "Round " & lngRound
lngGameCount = 1
For lngGame = 2 + blnTeamsEven To lngNoOfGames + blnTeamsEven + 1
Set oGame = New clsGame
Games.Add oGame
With oGame
.Name = "Game " & lngGameCount
.HomeTeam = aoTeam(lngGame)
.AwayTeam = aoTeam(lngNoofTeams - lngGame + 2 + blnTeamsEven)
.HomeTeam.Games.Add oGame
.AwayTeam.Games.Add oGame
End With
lngGameCount = lngGameCount + 1
Next lngGame
Set oRound.GameAdd = Games
Call Rotate(aoTeam(), blnTeamsEven)
Next lngRound
Set oTournament.RoundAdd = Rounds
Set oTeam = Nothing
Set oRound = Nothing
Set oGame = Nothing
Set Games = Nothing
End Sub
Sub Populate_Team_Names()
Dim oTeam As clsTeam
Dim lngTeam As Long
lngTeam = 1
For Each oTeam In Teams ' Retrieve team names from Data sheet
oTeam.Name = Range("Team_Names").Offset(lngTeam).Value
oTeam.Colour = Range("Team_Names").Offset(lngTeam).Interior.Color
lngTeam = lngTeam + 1
Next
End Sub
Sub Reset_Scores()
Dim lngRound As Long
Dim lngGame As Long
For lngRound = 1 To lngNoOfRounds
For lngGame = 1 To lngNoOfGames
With Rounds(lngRound).Games(lngGame)
.HomeGoals = -1
.AwayGoals = -1
End With
Next
Next
End Sub
Sub Rotate(ByRef aoTeam() As clsTeam, blnTeamsEven As Boolean)
Dim e As Integer
Dim v1 As clsTeam
Set v1 = aoTeam(1)
For e = 2 To UBound(aoTeam()) + blnTeamsEven
Set aoTeam(e - 1) = aoTeam(e)
Next
Set aoTeam(UBound(aoTeam()) + blnTeamsEven) = v1
End Sub
Function lngNoTeams() As Long
Dim r As Range
For Each r In Range("Team_Names").Offset(1).Resize(32)
If r.EntireRow.Hidden = False Then lngNoTeams = lngNoTeams + 1
Next
End Function
Function lngNoRounds() As Long
lngNoRounds = lngNoofTeams + (lngNoofTeams / 2 = Int(lngNoofTeams / 2))
End Function
Function lngNoGames() As Long
lngNoGames = (lngNoofTeams - (lngNoofTeams / 2 = Int(lngNoofTeams / 2))) / 2
End Function
Sub Change_Team_Names()
Worksheets("Teams").Activate
End Sub
Sub Goto_League_Table()
Worksheets("Fixtures").Activate
End Sub
Sub Goto_Knockout_Rounds()
Worksheets("Finals").Activate
End Sub
Sub Quit()
ThisWorkbook.Close
End Sub
Sub Save_Tournament()
ThisWorkbook.Save
End Sub
Sub Splash_Screen()
Worksheets("Title").Activate
[a1].Select
[h15].Select
End Sub
