database - 如何使用 VBA 循环 Access 某些记录、检查查询并有条件地分配字段值？

Question

我正在努力实现以下目标:

使用 VBA 循环遍历表格，并使用以下三个参数指定人员坐在餐 table 上:

1) 个人的优先级分数。

2) 个人对坐在哪张 table 上的偏好。

3) table 的座位数。

理想情况下，VBA 将从优先级 1 组的第一条记录开始，分配尽可能多的人员到表 1 中，然后根据他们的偏好继续分配优先级 1 人员，同时检查他们的首选表是否在满负荷运转。

在为所有优先级 1 的个体分配了一个表(在表对象中给出“Table_Assignment”值)后，VBA 会转移到优先级 2 的个体，依此类推。

在我的数据库中，我有下表(名为“tbl_Assignments”的表对象):

RecordID | Table_Assignment | Priority |   Title      | Preference_1 | Preference_2 |... Preference_n

  001                            1        CEO               Table1                      
  002                            1        CEO-spouse        Table1 
  003                            1        VP                Table1         Table2 
  004                            1        VP-spouse         Table1         Table2
  005                            2        AVP               Table1         Table2
  006                            2        AVP-spouse        Table1         Table2
  007                            3        Chief counsel     Table1         Table2          Table_n
  008                            3        COO               Table1         Table2          Table_n 

此外，我创建了一个查询，告诉您在对表进行分配时还剩下多少空缺(名为“qry_capacity_sub1”的查询对象):

TableID | Maximum_seating | Seats_taken | Vacancies

 Table1         4                3            1             
 Table2         4                2            2
 Table3         4                0            4
 Table4         4                1            3

我尝试使用循环编写 VBA，这将实现循环遍历表(“tbl_Assignments”)并在单击表单上的命令按钮后为“Table_Assignment”字段分配值的目标。

更新(11/09/2014):将 VBA 更新到我现在在此过程中的位置。对 VBA 的更改也反射(reflect)了 Jérôme Teisseire 的建议。

以下 VBA 从我在这里看到的开始:Looping Through Table, Changing Field Values

Private Sub Command0_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String


Set db = CurrentDb()

strSQL = "Select RecordID, Table_Assignment, Priority, Preference_1, Preference_2, Preference_3 FROM tbl_Assignments WHERE Priority =1"

Set rs = db.OpenRecordset(strSQL)

On Error GoTo Err_Handler

Do Until rs.EOF
  With rs
If there are seats available at your first preferred table Then
     .Edit
     !Table_Assignment = rs!Preference_1
     .Update
     .MoveNext
     End If
If the first table you preferred has reached capacity, and there are seats left in your second preferred table Then 
     .Edit
     !Table_Assignment = rs!Preference_2
     .Update
     .MoveNext
    End If
'..keep checking each the person's preferred tables. If they cannot be assigned a table because their preferred tables are at capacity...
Else
     .Edit
     !Table_Assignment = "Unassigned"
     .Update
     .MoveNext
  End With
Loop

rs.Close

Exit_Handler:
    Set rs = Nothing
    Set db = Nothing
    Exit Sub
Err_Handler:
   MsgBox "You need to debug"
   Resume Exit_Handler

   End Sub

Answer 1

可能 qry_capacity_sub1 依赖于 tbl_Assignments，当您尝试同时查询和更新它时，它会导致 Access 崩溃。为了验证这一点，您尝试用一些虚假检查替换 DLookup 条件，例如

If True Then
...

只是为了验证其余代码是否正常工作。

此外，我认为 DLookup 条件中的代码中存在另一个逻辑错误 - “TableID='Preference_1'” 将搜索“Preference_1”字符串，但不搜索列值。我认为它一定是“TableID='” + rs!Preference_1 + “'”之类的东西，但恐怕这也没有帮助。

我建议您将每个表的空缺缓存到 in-memory dictionary并在每次分配 table 时减少空位。所以代码可能类似于下面给出的内容。另请注意，最好不要将 MoveNext 嵌套在任何 If 中，以确保不会出现无限循环(这也可能是崩溃的原因)。

Private Sub Command0_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Dim VacancyPerTable As New Scripting.dictionary

Set db = CurrentDb()

Set rsVac = db.OpenRecordset("SELECT DISTINCT TableID, Vacancies FROM qry_capacity_sub1")
While Not rsVac.EOF
    VacancyPerTable.Add rsVac!TableID, rsVac!Vacancies
Loop
rsVac.Close

strSQL = "Select RecordID, Table_Assignment, Priority, Preference_1, Preference_2, Preference_3 FROM tbl_Assignments WHERE Priority =1"

Set rs = db.OpenRecordset(strSQL)

On Error GoTo Err_Handler

Do Until rs.EOF
    With rs
        If VacancyPerTable(!Preference_1) > 0 Then
            .Edit
            !Table_Assignment = rs.Fields(3)
            .Update
            VacancyPerTable(!Preference_1) = VacancyPerTable(!Preference_1) - 1
        ElseIf VacancyPerTable(!Preference_2) > 0 Then
            .Edit
            !Table_Assignment = rs.Fields(4)
            .Update
            VacancyPerTable(!Preference_2) = VacancyPerTable(!Preference_2) - 1
        ElseIf VacancyPerTable(!Preference_3) > 0 Then
            .Edit
            !Table_Assignment = rs.Fields(5)
            .Update
            VacancyPerTable(!Preference_3) = VacancyPerTable(!Preference_3) - 1
        Else
            .Edit
            !Table_Assignment = "UnAssigned"
            .Update
        End If
        .MoveNext
    End With
Loop

rs.Close

Exit_Handler:
    Set rs = Nothing
    Set db = Nothing
    Exit Sub
Err_Handler:
   MsgBox "You need to debug"
   Resume Exit_Handler

End Sub