MS Access编译错误：类型不匹配（需数组或自定义类型）求助

我编写了一段用于生成联赛赛程的VBA代码，但始终触发「MS Access Compile Error: Type Mismatch array or User-defined type expected」编译错误，尝试多种修改后仍无法解决，恳请提供技术帮助。

代码功能说明 #

该代码用于为联赛生成赛程，每周每支球队与同联赛另一支球队进行一场比赛，周数由numberOfWeeks字段决定，联赛期间每两队仅交手一次。

原代码 #

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

错误原因 #

编译错误的核心是ShuffleArray函数声明的参数为ByRef arr() As Variant（Variant类型数组），但调用时传入的TeamIDs()是Long类型数组、teamNames()是String类型数组，强类型数组与Variant数组不兼容，触发类型不匹配。

解决方案 #

以下两种方案任选其一即可：

方案一：修改ShuffleArray函数为通用数组处理

将函数参数改为接受任意类型数组，调整内部逻辑：

' 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
    Dim arrLBound As Long, arrUBound As Long

    arrLBound = LBound(arr)
    arrUBound = UBound(arr)

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

        ' Swap the elements
        temp = arr(i)
        arr(i) = arr(j)
        arr(j) = temp
    Next i
End Sub

方案二：将数组声明为Variant类型

在GenerateFixtures子过程中，把两个数组的类型改为Variant：

Dim TeamIDs() As Variant
Dim teamNames() As Variant

后续赋值、调整数组大小的逻辑保持不变，即可匹配ShuffleArray的参数要求。

额外优化提示 #

1. 当前随机配对逻辑会导致重复交手，若要实现每两队仅交手一次，需使用循环赛制的轮转算法，而非每周随机打乱。
2. 生成新赛程前，建议清空Match表中对应联赛的旧记录，避免重复数据。
3. 增加球队数量为奇数时的轮空处理逻辑。

内容的提问来源于stack exchange，提问作者coka01