Question

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

使用VBA循环查看表格，并使用以下三个参数指定人员坐在餐桌上：

1）个人的优先得分。

2）个人对坐在哪个桌子上的偏好。

3）桌子的座位容量。

理想情况下，VBA将从优先级1组的第一个记录开始，分配可以放在Table1中的人数，然后根据他们的偏好继续分配优先级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'字段分配值。

更新（2014年9月11日）：现在将VBA更新到我在此过程中的位置。 VBA的变化也反映了JérômeTeisseire的建议。

以下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，当您尝试查询并同时更新它时会导致访问崩溃。要验证这一点，您尝试用一些假检查替换您的DLookup条件，例如

If True Then
...

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

此外，我认为您的代码在DLookup条件中存在另一个逻辑错误 - ＆＃34; TableID =＆＃39; Preference_1＆＃39;＆＃34;将搜索＆＃39; Preference_1＆＃39;字符串但不是列值。我认为它必须是骗子＆＃34; TableID =＆＃39;＆＃34; + rs！Preference_1 +＆＃34;＆＃39;＆＃34;，但我担心这也无济于事。

我建议您将每个表的空位缓存到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

Answer 2

你没有测试VLookup的null值，所以你必须有一个无限循环，
有人打电话给.MoveNext，rs.EOF等于true 更改您的代码：

Do Until rs.EOF 
  With rs
    If (DLookup("Vacancies", "qry_capacitycheck", "Dinner_Tbl_Name='Table1'")) > 0 Then
     .Edit
     !Table_Assignment = Table1
     .Update
     .MoveNext
    else
      .Edit
      !Table_Assignment = "UnAssigned"
      .Update
      .MoveNext
    End If
  End With
Loop

如何使用VBA循环访问某些记录，检查查询以及有条件地分配字段值？

2 个答案: