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.
Code is trying to pass array object to array variable of a different type. This won't work. Options:
Change code to declare a variant object variable which can hold anything.
Sub ShuffleArray(ByRef arr As Variant)
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)
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