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

Question

我正在努力完成以下任务:

使用 VBA 循环遍历一个表格，并使用以下三个参数分配餐 table 上的座位:

1) 个人的优先级分数。

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

3) table 的座位数。

理想情况下，VBA 会从 Priority 1 组的第一条记录开始，分配尽可能多的人可以放在 Table1 中，然后继续根据他们的偏好分配 Priority 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”字符串而不是列值。我认为它一定是 liek "TableID='"+ rs!Preference_1 + "'"，但恐怕这也无济于事。

我建议您将每个表的空缺缓存到 in-memory dictionary 中并在每次分配表格时减少空缺。所以代码可能类似于下面给出的。另请注意，最好不要将 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