How do I loop through certain records, check a query, and conditionally assign field value using VBA?

Question

I am trying to accomplish the following:

Use VBA to loop through a table, and assign people to be seated at dinner tables using the following three parameters:

1) The individual's priority score.

2) The individual's preferences on what table to be seated at.

3) The seating capacity of the table.

Ideally, the VBA would start from the 1st record of Priority 1 group, assign as many people as can be placed in Table1, and then continue assigning Priority 1 individuals according to their preference, while checking to see if their preferred tables are at capacity.

After all Priority 1 individuals are assigned a table (given a 'Table_Assignment' value in the table object), the VBA moves to Priority 2 individuals, and so forth.

In my database, I have the following table (table object called '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

Additionally, I have created a query tells you how many vacancies are left as assignments to tables are being made (query object called '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

I have attempted to write VBA, with a loop, that would accomplish my goal of looping through the table ('tbl_Assignments') and assigning values for the 'Table_Assignment' field once a command button is clicked on a form.

Update (11/09/2014): Updated the VBA to where I am in this process now. The changes to the VBA also reflect Jérôme Teisseire's suggestion.

The following VBA started from what I saw here: 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

Have you tried stepping through the code? Is there an individual line where it crashes? — Degustaf, Nov 10 '14 at 16:12

score 3 · Accepted Answer · edited May 23 '17 at 12:27

Probably qry_capacity_sub1 relies on tbl_Assignments and when you're trying to query and update it at the same time it makes access crash.. To verify this you try to replace your DLookup conditions with some fake checks like

If True Then
...

just to verify that the rest of the code works properly.

Also I think there is another logical mistake in your code in DLookup conditions - "TableID='Preference_1'" will search for a 'Preference_1' string but not the column value. I think it must be something liek "TableID='" + rs!Preference_1 + "'", but I afraid this will not help as well.

I'd suggest you to cache vacancies per table into in-memory dictionary and decrement vacancy each time you assign the table. So the code could be something like the given below. Also note that it is better not to nest MoveNext in any If to be sure that there will be no endless loop (this could be also the cause of the crash).

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

This solution worked perfectly. Thanks for making me aware of dictionary objects. In order for this to work, I had to make sure that the values I was passing from the rs object to the dictionary object were strings (using Cstr). Additionally, I had to use CStr to make sure that the if statements were being read correctly. I also had to move '.MoveNext', and nest it in between the End If and End With. — ealfons1, Nov 10 '14 at 19:09
@ealfons1 regarding MoveNext - you're right that was a typo, text was written in notepad++ without any syntax check. Regarding CStr - well, may be it is required as well, not sure. Glad that it has helped. — sarh, Nov 10 '14 at 21:23

score 0 · Answer 2 · answered Nov 08 '14 at 16:33

0

you don't test null value for DLookup , so you must have an inifinity loop,
some call to .MoveNext missing and you never have rs.EOF equal true
change your code in:

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

answered Nov 08 '14 at 16:33

Jérôme Teisseire

1,518
1
16
26

Your suggestion is great. However, because I failed to elucidate it in the VBA I originally provided above, I would also like the code to go through all of the preferences as well, checking them for vacancy, before finally assigning a value of "Unassigned". – ealfons1 Nov 08 '14 at 20:16

How do I loop through certain records, check a query, and conditionally assign field value using VBA?

2 Answers2