MS Access VBA: Adding multiple Objects to a collection

Question

I am attempting to add multiple objects to a collection.

I have a few loops building and populating my object then adding the object to the collection.

The problem is that when I watch the collection it shows all the objects being the same instead of each having the data from the record that built them.

How can I correct this? Do I need to deconstruct my object before rebuilding the next object?

Public Sub processPurchases()

'DB Connection
Dim dbs As Database
Set dbs = CurrentDb
Dim rstPurchases As Recordset
Set rstPurchases = dbs.OpenRecordset("qryPurchasesByCardHolder")

'Decalre Variables
Dim counter As Integer
Dim iteration As Integer
Dim bCode As String
Dim transDate As String
Dim ven As String
Dim amt As String
Dim req As String
Dim desc As String
Dim Purchases As New Collection
iteration = 0

If rstPurchases.RecordCount > 0 Then
    rstPurchases.MoveFirst
    Do While Not rstPurchases.EOF
        iteration = iteration + 1
        counter = 0
        Do While counter < 11
            counter = counter + 1
            Dim p As String
            p = ("Purchase" & iteration & "-" & counter)
            Dim Purchase As New clsPurchaseItem
            bCode = "budgetCode" & counter
            transDate = "transDate" & counter
            ven = "vendor" & counter
            amt = "amount" & counter
            req = "requestedBy" & counter
            desc = "description" & counter
            If Not rstPurchases.Fields(bCode).value = "" Then
                MsgBox p
                Purchase.CardHolderID = rstPurchases.Fields("cardEmpId").value
                MsgBox "Card Holder ID: " & Purchase.CardHolderID

                Purchase.CardHolderName = rstPurchases.Fields("cardName").value
                MsgBox "Card Holder Name: " & Purchase.CardHolderName

                Purchase.StatementDate = rstPurchases.Fields("currDate").value
                MsgBox "Statement Date: " & Purchase.StatementDate

                Purchase.Department = rstPurchases.Fields("deptname").value
                MsgBox "Department: " & Purchase.Department

                Purchase.BudgetCode = rstPurchases.Fields(bCode).value
                MsgBox "Budget Code: " & Purchase.BudgetCode

                Purchase.TransactionDate = rstPurchases.Fields(transDate).value
                MsgBox "Transaction Date: " & Purchase.TransactionDate

                Purchase.Vendor = rstPurchases.Fields(ven).value
                MsgBox "Vendor:" & Purchase.Vendor

                Purchase.Amount = rstPurchases.Fields(amt).value
                MsgBox "Purchase Amount: " & Purchase.Amount

                Purchase.RequestedBy = rstPurchases.Fields(req).value
                MsgBox "Requested By: " & Purchase.RequestedBy

                Purchase.Description = rstPurchases.Fields(desc).value
                MsgBox "Description: " & Purchase.Description

                Purchases.Add Purchase, p
            End If
        Loop
        rstPurchases.MoveNext
        MsgBox "Move To Next Record"
    Loop
End If
 MsgBox Purchases.Item("Purchase2-1").Description
End Sub

Answer 1

The problem is your use of Dim As New

Dim Purchase As New clsPurchaseItem may seem identical to Dim Purchase As clsPurchaseItem and Set Purchase = clsPurchaseItem, but it isn't. It only initializes Purchase once, and leaves it in a weird, indestructible state.

As Victor K said, you need to set it manually. But you also need to get rid of Dim As New:

Public Sub processPurchases()

'DB Connection
Dim dbs As Database
Set dbs = CurrentDb
Dim rstPurchases As Recordset
Set rstPurchases = dbs.OpenRecordset("qryPurchasesByCardHolder")

'Decalre Variables
Dim counter As Integer
Dim iteration As Integer
Dim bCode As String
Dim transDate As String
Dim ven As String
Dim amt As String
Dim req As String
Dim desc As String
Dim Purchases As New Collection
iteration = 0

If rstPurchases.RecordCount > 0 Then
    rstPurchases.MoveFirst
    Do While Not rstPurchases.EOF
        iteration = iteration + 1
        counter = 0
        Do While counter < 11
            counter = counter + 1
            Dim p As String
            p = ("Purchase" & iteration & "-" & counter)
            Dim Purchase As clsPurchaseItem
            Set Purchase = New clsPurchaseItem
            bCode = "budgetCode" & counter
            transDate = "transDate" & counter
            ven = "vendor" & counter
            amt = "amount" & counter
            req = "requestedBy" & counter
            desc = "description" & counter
            If Not rstPurchases.Fields(bCode).value = "" Then
                MsgBox p
                Purchase.CardHolderID = rstPurchases.Fields("cardEmpId").value
                MsgBox "Card Holder ID: " & Purchase.CardHolderID

                Purchase.CardHolderName = rstPurchases.Fields("cardName").value
                MsgBox "Card Holder Name: " & Purchase.CardHolderName

                Purchase.StatementDate = rstPurchases.Fields("currDate").value
                MsgBox "Statement Date: " & Purchase.StatementDate

                Purchase.Department = rstPurchases.Fields("deptname").value
                MsgBox "Department: " & Purchase.Department

                Purchase.BudgetCode = rstPurchases.Fields(bCode).value
                MsgBox "Budget Code: " & Purchase.BudgetCode

                Purchase.TransactionDate = rstPurchases.Fields(transDate).value
                MsgBox "Transaction Date: " & Purchase.TransactionDate

                Purchase.Vendor = rstPurchases.Fields(ven).value
                MsgBox "Vendor:" & Purchase.Vendor

                Purchase.Amount = rstPurchases.Fields(amt).value
                MsgBox "Purchase Amount: " & Purchase.Amount

                Purchase.RequestedBy = rstPurchases.Fields(req).value
                MsgBox "Requested By: " & Purchase.RequestedBy

                Purchase.Description = rstPurchases.Fields(desc).value
                MsgBox "Description: " & Purchase.Description

                Purchases.Add Purchase, p
            End If
        Loop
        rstPurchases.MoveNext
        MsgBox "Move To Next Record"
    Loop
End If
 MsgBox Purchases.Item("Purchase2-1").Description
End Sub