MS Access Compile Error: Type Mismatch array or User-defined type expected

Question

I have the following code that I keep getting the type mismatch array error. I have tried a number of different changes and can not figure it out. Any help would be appreciated

Option Compare Database
Option Explicit

' Helper function to shuffle an array using the Fisher-Yates algorithm
Sub ShuffleArray(ByRef arr() As Variant)
    Dim i As Long, j As Long
    Dim temp As Variant

    For i = UBound(arr) To LBound(arr) + 1 Step -1
        ' Calculate the index to swap with
        j = Int((i - LBound(arr) + 1) * Rnd + LBound(arr))

        ' Swap the elements
        temp = arr(i)
        arr(i) = arr(j)
        arr(j) = temp
    Next i
End Sub
Sub GenerateFixtures()
    ' Declare variables
    Dim db As DAO.Database
    Dim rsTeams As DAO.Recordset
    Dim rsMatch As DAO.Recordset
    Dim leagueID As Long
    Dim league As String
    Dim startDate As Date
    Dim numberOfWeeks As Integer
    Dim currentWeek As Integer
    Dim teamCount As Integer
    Dim TeamIDs() As Long
    Dim teamNames() As String
    Dim i As Integer, j As Integer

    ' Set the league ID for which you want to generate fixtures
    leagueID = 1 ' Change this to the desired league ID

    ' Open the database
    Set db = CurrentDb

    ' Get league details
    Dim leagueSQL As String
    leagueSQL = "SELECT LeagueID, League, StartDate, NumberOfWeeks FROM League WHERE LeagueID = " & leagueID
    Dim rsLeague As DAO.Recordset
    Set rsLeague = db.OpenRecordset(leagueSQL)

    If rsLeague.EOF Then
        MsgBox "League not found!", vbExclamation
        Exit Sub
    End If

    ' Get league details
    leagueID = rsLeague!leagueID
    league = rsLeague!league
    startDate = rsLeague!startDate
    numberOfWeeks = rsLeague!numberOfWeeks

    ' Close the league recordset
    rsLeague.Close

    ' Get team details for the specified league
    Dim teamsSQL As String
    teamsSQL = "SELECT ID, Team FROM Teams WHERE LeagueID = " & leagueID
    Set rsTeams = db.OpenRecordset(teamsSQL)

    ' Initialize arrays to store team IDs and names
    Dim maxTeamCount As Integer
    maxTeamCount = 100 ' Set a maximum count, adjust as needed

    ReDim TeamIDs(1 To maxTeamCount)
    ReDim teamNames(1 To maxTeamCount)

    ' Loop through the recordset
    i = 1
    rsTeams.MoveFirst ' Ensure you start from the first record
    Do While Not rsTeams.EOF
        TeamIDs(i) = rsTeams!ID
        teamNames(i) = rsTeams!Team
        i = i + 1

        ' Exit loop if you reach the maximum count
        If i > maxTeamCount Then
            MsgBox "Exceeded the maximum team count.", vbExclamation
            Exit Do
        End If

        rsTeams.MoveNext
    Loop

    ' Resize arrays to the actual count
    ReDim Preserve TeamIDs(1 To i - 1)
    ReDim Preserve teamNames(1 To i - 1)

    ' Close the teams recordset
    rsTeams.Close

    ' Assign the teamCount variable after TeamIDs is populated
    teamCount = UBound(TeamIDs)


    ' Open the Match recordset for appending new fixtures
    Set rsMatch = db.OpenRecordset("Match", dbOpenDynaset)

   ' Generate fixtures using random pairing
    For currentWeek = 1 To numberOfWeeks
        ' Randomize the order of teams
        ShuffleArray TeamIDs
        ShuffleArray teamNames

        ' Loop through each team and create fixtures
        For i = 1 To teamCount - 1 Step 2
            ' Add a new record to the Match table
            rsMatch.AddNew
            rsMatch!leagueID = leagueID
            rsMatch!league = league
            rsMatch!Week = currentWeek
            rsMatch!MatchDate = startDate + (currentWeek - 1) * 7 ' Assuming matches are weekly
            rsMatch!teamAID = TeamIDs(i)
            rsMatch!TeamA = teamNames(i)
            rsMatch!teamBID = TeamIDs(i + 1)
            rsMatch!TeamB = teamNames(i + 1)
            rsMatch.Update
        Next i
    Next currentWeek

    ' Close the Match recordset
    rsMatch.Close

    ' Display a success message
    MsgBox "Fixtures generated successfully!", vbInformation
End Sub

this is to set up matches within a league. Each team should have one match per week against another team within the same league. The amount of weeks (and therefore matches) is dependent on the value in numberofweeks column. each team will only be matched against another team once during the duration of the league.

Answer 1

Code is trying to pass array object to array variable of a different type. This won't work. Options:

1. Change code to declare a variant object variable which can hold anything.
   Sub ShuffleArray(ByRef arr As Variant)

2. Not necessary to save team name and league ID or name into Match table as these data can be retrieved by joining tables in query. Eliminate teamNames array then can declare as long but this makes the helper proc less flexible.
   Sub ShuffleArray(ByRef arr() As Long)

3. Instead of passing array object, declare array variable(s) as Public in module header then any of that module's procedures can reference.

I tested options 1 and 2 and code runs without error but I am not certain resulting Match records are correct.

Consider that array can be populated from recordset using GetRows method instead of looping recordset. This will create a 2-dimension array so both procedures would have to be modified to handle that. Also, one query can retrieve team and league data and limit to 100 teams. Revised code:

Sub ShuffleArray(ByRef arr As Variant)
    Dim i As Long, j As Long
    Dim temp As Variant

    For i = UBound(arr, 2) To LBound(arr, 2) + 1 Step -1
        ' Calculate the index to swap with
        j = Int((i - LBound(arr, 2) + 1) * Rnd + LBound(arr, 2))
        ' Swap the elements
        temp = arr(0, i)
        arr(0, i) = arr(0, j)
        arr(0, j) = temp
    Next i
End Sub

Sub GenerateFixtures()
    ' Declare variables
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim rsMatch As DAO.Recordset
    Dim leagueID As Long
    Dim currentWeek As Integer
    Dim TeamIDs As Variant
    Dim i As Integer, j As Integer

    ' Set the league ID for which you want to generate fixtures
    leagueID = 1 ' Reference a textbox on form for input

    ' Open database
    Set db = CurrentDb

    ' Get data
    Set rs = db.OpenRecordset("SELECT TOP 100 ID, StartDate, NumberOfWeeks FROM Teams " & _
            "INNER JOIN League ON Teams.LeagueID=League.LeagueID WHERE Teams.LeagueID = " & leagueID & " ORDER BY ID")

    If rs.EOF Then
        MsgBox "League not found!", vbExclamation
    
    Else
        rs.MoveLast
        rs.MoveFirst
        TeamIDs = rs.GetRows(rs.recordCount)
        ' Open Match recordset for appending new fixtures
        Set rsMatch = db.OpenRecordset("Match", dbOpenDynaset)
        rs.MoveFirst
       ' Generate fixtures using random pairing
        For currentWeek = 1 To rs!numberOfWeeks
            ' Randomize the order of teams
            ShuffleArray TeamIDs
            ' Loop through each team and create fixtures
            For i = 0 To UBound(TeamIDs, 2) - 1 Step 2
                ' Add a new record to the Match table
                rsMatch.AddNew
                rsMatch!Week = currentWeek
                rsMatch!MatchDate = rs!startDate + (currentWeek - 1) * 7 ' Assuming matches are weekly
                rsMatch!teamAID = TeamIDs(0, i)
                rsMatch!teamBID = TeamIDs(0, i + 1)
                rsMatch.Update
            Next i
        Next currentWeek
        rsMatch.Close
        ' Display a success message
        MsgBox "Fixtures generated successfully!", vbInformation
    End If
    rs.Close
End Sub