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