It seems appropriate given the name of this site and 2014 being a world cup year that I might post something on code that I found a while back now related to establishing fixtures in a league coded by, for me, a mythical character. Back then I was taking part in a squash league with some friends and we needed to figure out some way of organising the matches for everyone. Seemed simple enough everyone plays everyone else on consecutive weekends. Turns out its not quite so easy and there’s a whole branch of mathematics called combinatronics that specifically looks at the way of optimising this kind of problem. In that really humble syntax of mathematicians I heard this phrase being banded about – a non trivial problem. As ever I turned to the internet and found some code by someone called Dev Ashish. Now I don’t know about you but prior to the internet I never had access to this kinds of expert and the power of the code really blew me away. The code very neatly creates the required number of matches in a table and allows me to organise matches for individuals to play each other and from there I was able to keep scores on everyone. It was in a word a bit of genius coding.
That was approximately 2005 and come 2014 and my blog the world cup reminded me of this amazing piece of coding.
I have my suspicions of where Dev Ashish is now but I can’t tell for sure.
Keyser Söze / Woland / Dev Ashish – they’re out there…
Joking aside many thanks to Dev Ashish for posting an amazing piece of code…
Option Compare Database
Option Explicit
Public intLeagueno As Integer
Public strLeaguenme As String
Function CalculateFixtures(ByVal Age As Integer, ByVal startdate As Date, ByVal EndDate As Date) As Integer
'**************************************************
' Set Database connections and Recordsets Variables
' Coded by Dev Ashish
'**************************************************
Dim cnn As ADODB.Connection
Dim rstTeams As ADODB.Recordset
Dim rstFixtures As ADODB.Recordset
'****************************************
' Create Integer Variables
'****************************************
Dim NumberofFixtures As Integer ' Number of Fixtures between teams
Dim NumberofMatches As Integer ' Number of Matches to be played
Dim NumberofTeams As Integer ' Number of Teams
Dim Week As Integer ' Week Number for Fixtures
Dim FirstTeam As Integer
Dim LastTeam As Integer
Dim StartPosition As Integer
Dim strtdate As String
Dim intMsgbox As Integer
strtdate = InputBox("Enter the date you want the league to start", "Question?")
If (strtdate = "") Then
intMsgbox = MsgBox("Thanks anyway")
startdate = 3500
Else
startdate = strtdate
intMsgbox = MsgBox("Calculating the fixtures starting" & " " & startdate, vbOKOnly, "Result")
End If
Dim iCounter As Integer
'****************************************
' Create Player String Variables
'****************************************
Dim Player1 As String
Dim Player2 As String
'****************************************
' Create Team/GameSequence Variables based on Number of Teams
'****************************************
Dim Team(50) As String
Dim GameSequence(50) As String
Dim TeamNames(1 To 50) As String
Set cnn = CurrentProject.Connection
Set rstTeams = New ADODB.Recordset
Set rstFixtures = New ADODB.Recordset
'*********************************************************
'Open the Tables Teams and Fixtures
'*********************************************************
rstTeams.Open "SELECT * FROM tblTeams Where leagueno = " & intLeagueno & "", cnn, adOpenKeyset, adLockOptimistic
'Where AgeGroup = 'u" & Age & "'"
rstFixtures.Open "tblFixtures", cnn, adOpenKeyset, adLockOptimistic
'****************************************************
' Read the Team Names into an Array
'****************************************************
iCounter = 1
Do While Not rstTeams.EOF
TeamNames(iCounter) = rstTeams.Fields("Team")
iCounter = iCounter + 1
rstTeams.MoveNext
Loop
'*****************************
'Set Main constants
'*****************************
NumberofTeams = iCounter - 1
NumberofFixtures = NumberofTeams - 1
NumberofMatches = NumberofTeams / 2
'*****************************************************
' Clear the Game Sequence Array
'*****************************************************
For iCounter = 1 To NumberofFixtures
GameSequence(iCounter) = ""
Next iCounter
'*****************************************************
' Clear the Teams Array
'*****************************************************
For iCounter = 1 To NumberofTeams
Team(iCounter) = iCounter
Next iCounter
FirstTeam = 0
'*****************************************************
' Create the Game Sequence ready for the fixtures
'*****************************************************
For Week = 1 To NumberofFixtures
FirstTeam = FirstTeam + 1
For iCounter = FirstTeam To FirstTeam + NumberofFixtures - 1
If iCounter > (NumberofFixtures) Then
LastTeam = iCounter - NumberofFixtures
Else
LastTeam = iCounter
End If
GameSequence(Week) = GameSequence(Week) & " " & Format(Team(LastTeam), "00")
Next iCounter
GameSequence(Week) = Trim(GameSequence(Week)) + " " & Format(Team(NumberofTeams), "00")
Next Week
'***************************************************
'Insert the new fixtures into the Table
'***************************************************
For Week = 1 To NumberofFixtures
StartPosition = 1
'Debug.Print "Week " & Week
For iCounter = 1 To NumberofMatches
Player1 = Mid(GameSequence(Week), StartPosition, 2)
Player2 = Left(Right(GameSequence(Week), (StartPosition) + 1), 2)
StartPosition = StartPosition + 3
rstFixtures.AddNew
rstFixtures.Fields("WeekNo") = Week
'rstFixtures.Fields("HomeTeam") = TeamNames(HomeTeam)
rstFixtures.Fields("Player1") = TeamNames(Player1)
'rstFixtures.Fields("AwayTeam") = TeamNames(AwayTeam)
rstFixtures.Fields("Player2") = TeamNames(Player2)
'rstFixtures.Fields("Age") = Age
rstFixtures.Fields("FixDate") = startdate
rstFixtures.Fields("Leagueno") = intLeagueno
rstFixtures.Update
Next iCounter
startdate = startdate + 7
If startdate > EndDate Then Week = NumberofFixtures + 1
Next Week
'****************************************
'Close the tables
'****************************************
rstTeams.Close
Set rstTeams = Nothing
rstFixtures.Close
Set rstFixtures = Nothing
End Function