在MS Access中如何从单人列表生成人员配对组合表？

一、前期表结构准备 #

先搭建两个核心表：

• 录入表（示例名tbl_Participants）：存储用户输入的单人参与数据，字段至少包含Person_ID（文本/数字型）、Activity_Date（日期型）、活动属性字段（如Activity_Name）。
• 配对结果表（示例名tbl_Pairings）：存储自动生成的配对记录，字段建议设为Pairing_ID（自动编号主键）、Person_A、Person_B、Activity_Date、Activity_Name（与录入表字段对应）。

二、VBA代码实现（绑定窗体按钮） #

将以下代码绑定到录入窗体的「生成配对」按钮点击事件，实现一键生成双向配对：

Private Sub btn_GeneratePairings_Click()
    Dim db As DAO.Database
    Dim rsParticipants As DAO.Recordset
    Dim rsPairings As DAO.Recordset
    Dim strSQL As String
    Dim currID As Variant, compID As Variant
    Dim actDate As Date, actName As String

    ' 初始化数据库连接
    Set db = CurrentDb()
    
    ' 筛选当前活动的所有参与人员（根据窗体当前录入的活动属性过滤）
    strSQL = "SELECT Person_ID, Activity_Date, Activity_Name FROM tbl_Participants " & _
             "WHERE Activity_Date = #" & Me.Activity_Date & "# AND Activity_Name = '" & Me.Activity_Name & "'"
    Set rsParticipants = db.OpenRecordset(strSQL)

    ' 打开配对表用于写入数据
    Set rsPairings = db.OpenRecordset("tbl_Pairings", dbOpenDynaset)

    ' 清除当前活动的旧配对记录（避免重复生成）
    db.Execute "DELETE FROM tbl_Pairings WHERE Activity_Date = #" & Me.Activity_Date & "# AND Activity_Name = '" & Me.Activity_Name & "'"

    ' 双重循环生成双向配对
    rsParticipants.MoveFirst
    Do While Not rsParticipants.EOF
        currID = rsParticipants!Person_ID
        actDate = rsParticipants!Activity_Date
        actName = rsParticipants!Activity_Name

        ' 克隆记录集遍历其他人员
        Dim rsClone As DAO.Recordset
        Set rsClone = rsParticipants.Clone
        rsClone.MoveNext ' 跳过自身，避免重复判断
        Do While Not rsClone.EOF
            compID = rsClone!Person_ID
            ' 添加A→B配对
            rsPairings.AddNew
            rsPairings!Person_A = currID
            rsPairings!Person_B = compID
            rsPairings!Activity_Date = actDate
            rsPairings!Activity_Name = actName
            rsPairings.Update

            ' 添加B→A配对（满足双向要求）
            rsPairings.AddNew
            rsPairings!Person_A = compID
            rsPairings!Person_B = currID
            rsPairings!Activity_Date = actDate
            rsPairings!Activity_Name = actName
            rsPairings.Update

            rsClone.MoveNext
        Loop
        Set rsClone = Nothing
        rsParticipants.MoveNext
    Loop

    ' 释放资源
    rsParticipants.Close
    rsPairings.Close
    Set rsParticipants = Nothing
    Set rsPairings = Nothing
    Set db = Nothing

    MsgBox "配对记录生成完成！", vbInformation
End Sub

三、无VBA替代方案（自连接查询） #

如果不想编写VBA，可直接用Access自连接查询生成配对，再通过宏或按钮执行追加操作：

SELECT 
    p1.Person_ID AS Person_A,
    p2.Person_ID AS Person_B,
    p1.Activity_Date,
    p1.Activity_Name
FROM 
    tbl_Participants p1,
    tbl_Participants p2
WHERE 
    p1.Activity_Date = p2.Activity_Date
    AND p1.Activity_Name = p2.Activity_Name
    AND p1.Person_ID <> p2.Person_ID;

将上述查询保存为qry_Pairings，可直接查看结果，或通过「追加查询」将结果写入tbl_Pairings表。

四、注意事项 #

• 若Person_ID为数字型，需去掉SQL语句中包裹ID的单引号；文本型则保留。
• 建议在录入窗体中用连续窗体布局，方便用户批量添加单人参与记录。
• 可根据实际需求调整代码或查询中的字段名，确保与表结构一致。

内容的提问来源于stack exchange，提问作者Danny-t82