如何检查字典中的字段值是否有条件地分配值？

时间：2014-11-13 15:10:20

标签： vba loops dictionary data-structures access-vba

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

使用VBA循环遍历表格，并使用以下三个参数为人们分配礼物：

1）个人的优先得分。

2）个人对接受礼物的偏好。

3）库存中可用礼品的数量。

理想情况下，VBA将从优先级1组的第一个记录开始，如果有库存则分配他们最喜欢的礼物，然后根据他们的偏好继续分配优先级1个人，同时检查库存。

在所有优先级为1的个人在表格对象'tbl_Gift_Assignments'中分配礼物（给定'Assigned_Gift'）后，VBA将移至优先级为2的个人，依此类推。

现在，我无法处理个人所具有的首选礼品未列在清单表中的实例。

在我的数据库中，我有下表（表对象名为'tbl_Gift_Assignments'）：

RecordID | Gift_Assignment | Priority |   Name      | Preference_1 | Preference_2 |... Preference_n

   001                          1        John          Sled         Racecar                      
   002                          1        Jane          Racecar      Television
   003                          1        Joe           Mobile       Jacuzzi   
   004                          1        Moe           PS4          Xbox
   005                          2        Sam           Laptop       PS4
   006                          2        Alek          Laptop       PS4
   007                          3        Paul          Jacuzzi      Xbox
   008                          3        Nicky         Racecar      Television

此外，我有一张表格告诉我库存中有多少库存物品（表格对象名为'tbl_Inventory'）：

ItemID | Number_in_stock 

 Laptop         4             
 PS4            4
 Xbox           4
 Television     4

为了完成这项任务，我使用字典对象将每个礼物的库存缓存到内存中的字典中。每次我将礼物分配给记录时，它会减少库存。

我到目前为止的VBA如下：

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Dim GiftInvDict As New Scripting.dictionary

Set db = CurrentDb()

Set rsInv = db.OpenRecordset("SELECT DISTINCT ItemID, Number_in_stock FROM tbl_Inventory")
While Not rsInv.EOF
    GiftsInvDict.Add Cstr(rsInv!ItemID), CInt(rsInv!Number_in_stock)
Loop
rsInv.Close

strSQL = "SELECT * FROM tbl_Gift_Assignments WHERE Priority =1"

Set rs = db.OpenRecordset(strSQL)

Do Until rs.EOF
    With rs
    'Process for each preferred item
    'Path #1_step_a: If preferred item is not in dictionary
        If Not GiftsInvDict.Exists(Cstr(rs!Preference_1)) Then
            ' Path #1_step_b: Add it to dictionary, with value of 0
            GiftsInvDict.Add Cstr(rsInv!Preference_1), 0 Then
            ' Path #1_step_c: Don't know how to tell it to jump
            ' to next preference
        End If
        ' Path #2_step_a: If preferred item is actually in dictionary
        ElseIf GiftInvDict.Exists(Cstr(rs!Preference_1)) Then
            ' Path #2_step_b: Check that the inventory is greater than 0
            If GiftsInvDict(Cstr(rs!Preference_1)) > 0 Then
                ' Path #2_step_c: If inventory greater than 0, change
                ''Gift_Assignment' value to preference
            .Edit
            !Gift_Assignment = rs!Preference_1
            .Update
            GiftsInvDict(!Preference_1) = GiftsInvDict(!Preference_1) - 1
            End If 
        'End of process for each preferred item 

        'Do the process again for 'Preference_2....Preference_N' until all preferences
        'are checked

        'If, after each preference has been through the process, preferred gifts cannot be assigned 
        'assign 'No_Gift_Available' value to 'Gift_Assignment' field
        Else
            .Edit
            !Gift_Assignment = "No_Gift_Available"
            .Update
        End If
        .MoveNext
    End With
Loop

rs.Close

Set rs = Nothing
Set db = Nothing

挑战

我知道个人列出了没有库存的偏好（未列入'tbl_Inventory'，如'Jacuzzi'，'Sled'，'Racecar'）。我当前的方法，因为我不知道如何使VBA跳过不在字典对象中的礼物首选项，是让VBA检查字典对象中是否存在首选项。如果没有，将键添加到字典中，其值为0.现在，VBA正跳到“Else”条件，即使他们有其他首选礼物，也不会向个人分配礼物。有库存（可能存在于字典对象中）。

1 个答案:

答案 0 :(得分：0)

我终于在您的代码方面取得了一些进展。不确定你是否对上述内容很匆忙，或者剪切/粘贴问题，但至少有5或6个编译错误我必须纠正。

我只是简化了您的代码，以便按顺序检查首选项。根据您的要求，您需要解决几件事。以下是我的建议：

  1. 修改您的查询以从tbl_GiftAssignments中选择ALL并按优先级排序。这样你就可以在一个循环中处理所有内容。
  2. 不确定有多少＆＃39;偏好＆＃39;你将拥有的字段，但是如果超过三个（或者它会改变），那么我建议在＆＃39; Do While＆＃39;中创建一个循环。这会旋转每一列。
  3. 我在最后添加了代码以更新库存计数，但不喜欢这种方法。我觉得它应该在礼品分配更新发生的同时发生。如果这个崩溃了，你将有一个皇家混乱。
  4. 我没有添加任何代码来向表中添加新项目。不确定这是不是你想要的。
  5. 最后，在处理Dictionary以添加新项目时存在一个错误。如果＆＃39; Racecar＆＃39;没有被发现，它被添加了，但是下次当有人寻找＆＃39; Racecar＆＃39;时，它又被添加了!!
  6. 终于（真的，最后）......你可以删除我所有的＆＃39; Debug.Print＆＃39;语句

    7. 以下是代码：

    Option Compare Database
Option Explicit

Sub Assign_Gifts()

Dim db              As DAO.Database
Dim rs              As DAO.Recordset
Dim rsINV           As DAO.Recordset                        ' ** Not Defined
Dim strSQL          As String
Dim GiftsInvDict    As New Scripting.Dictionary             ' ** Needed 's' / inconsistent
Dim i               As Integer
Dim iQTY            As Integer
Dim itemArray

    Set GiftsInvDict = New Scripting.Dictionary
    Set db = CurrentDb()

    Set rsINV = db.OpenRecordset("SELECT DISTINCT ItemID, Number_in_stock FROM tbl_Inventory")
    Do While Not rsINV.EOF          ' Changed to DO
        GiftsInvDict.add CStr(rsINV!ItemID), CInt(rsINV!Number_in_stock)
        rsINV.MoveNext                      ' Missing MOVENEXT
    Loop                ' ** Loop without Do
    rsINV.Close


    Debug.Print "----- INVENTORY -----"
    Debug.Print "Count: " & GiftsInvDict.Count & vbTab & "C2: " & UBound(GiftsInvDict.Keys) + 1 & vbTab & "C3: " & UBound(GiftsInvDict.Items) + 1
    For i = 0 To GiftsInvDict.Count - 1
        Debug.Print GiftsInvDict.Keys()(i), GiftsInvDict.Items()(i)
    Next i

    Debug.Print "----- NAMES -----"

    strSQL = "SELECT * FROM tbl_Gift_Assignments WHERE Priority =1"
    Set rs = db.OpenRecordset(strSQL)

    Do Until rs.EOF
        With rs
            Debug.Print rs!Name & vbTab & rs!Preference_1 & vbTab & rs!Preference_2 & vbTab & rs!Preference_n
            ' Check 1st Pref
            If Not GiftsInvDict.Exists(CStr(rs!Preference_1)) Then              ' Fails to find 'Racecar'!!!!
                Debug.Print "1st Pref not avail: " & rs!Preference_1 & vbTab & " add it "
                GiftsInvDict.Item(CStr(rs!Preference_1)) = 0
                Debug.Print "----- INVENTORY -----"
                Debug.Print "Count: " & GiftsInvDict.Count & vbTab & "C2: " & UBound(GiftsInvDict.Keys) + 1 & vbTab & "C3: " & UBound(GiftsInvDict.Items) + 1
                For i = 0 To GiftsInvDict.Count - 1
                    Debug.Print GiftsInvDict.Keys()(i), GiftsInvDict.Items()(i)
                Next i
                Debug.Print "---------------------"
            Else
                iQTY = CInt(GiftsInvDict.Item(CStr(rs!Preference_1)))
                If iQTY > 0 Then
                    .Edit
                    !Gift_Assignment = rs!Preference_1
                    .Update
                    GiftsInvDict.Item(CStr(rs!Preference_1)) = CInt(iQTY - 1)
                    GoTo Satisfied
                End If
            End If

            ' Check 2nd Pref
            If Not GiftsInvDict.Exists(CStr(rs!Preference_2)) Then
                Debug.Print "2nd Pref not avail: " & rs!Preference_2 & vbTab & " add it "
                GiftsInvDict.Item(CStr(rs!Preference_2)) = 0
                Debug.Print "----- INVENTORY -----"
                Debug.Print "Count: " & GiftsInvDict.Count & vbTab & "C2: " & UBound(GiftsInvDict.Keys) + 1 & vbTab & "C3: " & UBound(GiftsInvDict.Items) + 1
                For i = 0 To GiftsInvDict.Count - 1
                    Debug.Print GiftsInvDict.Keys()(i), GiftsInvDict.Items()(i)
                Next i
                Debug.Print "---------------------"

            Else
                iQTY = CInt(GiftsInvDict.Item(CStr(rs!Preference_2)))
                If iQTY > 0 Then
                    .Edit
                    !Gift_Assignment = rs!Preference_2
                    .Update
                    GiftsInvDict.Item((CStr(rs!Preference_2))) = CInt(iQTY - 1)
                    GoTo Satisfied
                End If
            End If

            ' Try 3rd choice --- being lazy, BUT I WOULD CHANGE ALL THIS CODE TO HANDLE ANY NUMBER OF PREDERENCES!!
            If Not IsNull(rs!Preference_n) Then
                If Not GiftsInvDict.Exists(CStr(rs!Preference_n)) Then
                    Debug.Print "nth Pref not avail: " & rs!Preference_n & vbTab & " add it "
                    GiftsInvDict.Item(CStr(rs!Preference_n)) = 0
                    Debug.Print "----- INVENTORY -----"
                    Debug.Print "Count: " & GiftsInvDict.Count & vbTab & "C2: " & UBound(GiftsInvDict.Keys) + 1 & vbTab & "C3: " & UBound(GiftsInvDict.Items) + 1
                    For i = 0 To GiftsInvDict.Count - 1
                        Debug.Print GiftsInvDict.Keys()(i), GiftsInvDict.Items()(i)
                    Next i
                    Debug.Print "---------------------"

                Else
                    iQTY = CInt(GiftsInvDict.Item(CStr(rs!Preference_n)))
                    If iQTY > 0 Then
                        .Edit
                        !Gift_Assignment = rs!Preference_n
                        .Update
                        GiftsInvDict.Item(!Preference_n) = CInt(iQTY - 1)
                        GoTo Satisfied
                    End If
                End If
            Else
                Debug.Print "Pref_n is NULL"
            End If

            .Edit
            !Gift_Assignment = "No_Gift_Available"
            .Update

            'End of process for each preferred item

            'Do the process again for 'Preference_2....Preference_N' until all preferences
            'are checked

            'If, after each preference has been through the process, preferred gifts cannot be assigned
            'assign 'No_Gift_Available' value to 'Gift_Assignment' field
Satisfied:
            .MoveNext
        End With
    Loop

    rs.Close

    Debug.Print "-----------------------------------------------------------------------"

    'Add code to insert new records into Inventory if desired....
    For i = 0 To GiftsInvDict.Count - 1
        Debug.Print GiftsInvDict.Keys()(i), GiftsInvDict.Items()(i)
        strSQL = "UPDATE tbl_Inventory SET tbl_Inventory.Number_in_stock = " & CInt(GiftsInvDict.Items()(i)) & " " & _
                 "WHERE (((tbl_Inventory.ItemID)='" & CStr(GiftsInvDict.Keys()(i)) & "'));"
        db.Execute strSQL, , iRecAff
    Next i

    Set rs = Nothing
    Set db = Nothing

End Sub
相关问题
最新问题