Option Compare Database
Option Explicit
Public Sub AllocateWeekNumbers(vTotal As Long)
'Calculate the week numbers for a given number of teams in a league
'Entry (vTotal) = Number of teams in the league (must be between 6 and 26 and must be an even number)
'Exit (tblFixtures) holds list of fixtures
Dim vRow As Long, vWeekNo As Long, vCount As Long
Dim vGroups As String, vTemp As String, vHome As String, vAway As String
Dim vArray()
On Error GoTo ErrorCode
MarkTeams 'allocate a reference letter to each selected team
ReDim vArray(3 - 1, ((vTotal / 2) * (vTotal - 1)) - 1) 'set Array size (3 cols * 1 row for each fixture)
vGroups = Left("ABCDEFGHIJKLMNOPQRSTUVWXYZ", vTotal) 'set vGroups to letters reqd
vRow = 0
For vWeekNo = 1 To vTotal - 1 'for the number weeks per season - 1
For vCount = 1 To vTotal / 2 'for the number of matches each week
vArray(0, vRow) = Mid(vGroups, vCount, 1) 'fetch home team code
vArray(1, vRow) = Mid(vGroups, vCount + (vTotal / 2), 1) 'fetch away team code
vArray(2, vRow) = vWeekNo 'fetch week number
If vWeekNo Mod 2 = 0 And vArray(0, vRow) = "A" Then 'on even number weeks swap A to away match
vTemp = vArray(0, vRow)
vArray(0, vRow) = vArray(1, vRow)
vArray(1, vRow) = vTemp
End If
vRow = vRow + 1 'next row
Next
vTemp = "A" & Mid(vGroups, 3, (Len(vGroups) / 2) - 2) & Right(vGroups, 1) 'fetch next group
vGroups = vTemp & Mid(vGroups, 2, 1) & Mid(vGroups, Len(vGroups) / 2 + 1, (Len(vGroups) / 2) - 1) 'and build new order
Next
CurrentDb.Execute "DELETE FROM tblFixtures" 'delete Fixtures table data first
For vCount = 0 To UBound(vArray, 2) 'scan all rows in array
vHome = DLookup("TeamName", "tblTeams", "TeamCode = '" & vArray(0, vCount) & "'") 'fetch Home team name
vAway = DLookup("TeamName", "tblTeams", "TeamCode = '" & vArray(1, vCount) & "'") 'fetch Away team name
CurrentDb.Execute "INSERT INTO tblFixtures (HomeTeam, AwayTeam, WeekNo) VALUES (" _
& "'" & vHome & "', " _
& "'" & vAway & "', " _
& vArray(2, vCount) & ")" 'add Team and Week No data to Fixtures table
Next
Exit Sub
ErrorCode:
MsgBox Err.Description
End Sub
Public Sub MarkTeams()
'Enter letters A-n into TeamCode field for selected teams
Dim vCode As Long
Dim rst As Recordset
CurrentDb.Execute "UPDATE tblTeams SET TeamCode = NULL" 'clear TeamCode field in ALL team records
vCode = 65 'start at letter A
Set rst = CurrentDb.OpenRecordset("SELECT TeamCode FROM tblTeams " _
& "WHERE Active = True ORDER BY TeamName") 'create list of selected teams
Do Until rst.EOF
rst.Edit
rst!TeamCode = Chr(vCode) 'copy current letter code to TeamCode field
rst.Update
vCode = vCode + 1 'inc letter code
rst.MoveNext 'next team
Loop
rst.Close
Set rst = Nothing
End Sub
Public Sub AllocateSecondHalf()
'Add new fixtures to tblFixtures for second half of season (same as First Half but with Home & Away teams reversed)
'Entry (tblFixtures) holds list of fixtures for first half of season
'Exit (tblFixtures) holds list of fixtures for full season
Dim rst As Recordset
Dim vWeekNo As Long
vWeekNo = DMax("WeekNo", "tblFixtures") 'fetch highest week number
Set rst = CurrentDb.OpenRecordset("SELECT * FROM tblFixtures ORDER BY HomeTeam") 'create list of fixtures
Do Until rst.EOF
CurrentDb.Execute "INSERT INTO tblFixtures (HomeTeam, AwayTeam, WeekNo) VALUES (" _
& "'" & rst!AwayTeam & "', " _
& "'" & rst!HomeTeam & "', " _
& rst!WeekNo + vWeekNo & ")" 'add Team and Week No data to Fixtures table
rst.MoveNext 'next fixture
Loop
rst.Close
Set rst = Nothing
End Sub