How to add data to a new dictionary in Ms Access using VBA

Hankwembo Christopher,FCCA,FZICA,CIA,MAAT,B.A.Sc
Hankwembo Christopher,FCCA,FZICA,CIA,MAAT,B.A.Sc used Ask the Experts™
on
I'm trying to add data to the dictionary in ms access 2016 but the data collected via a SELECT query is not being added , kindly help me to spot the mistake on the code below. To be sure I want to print the data using a message, only then can I take the data to its final destination:

Private Sub CmdSales_Click()
    Dim jsonitems As New Collection
    Dim jsonDictionery As New Dictionary
    Dim i As Long
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim item As Variant
    Set db = CurrentDb
    Set rs = db.OpenRecordset("Qry1")
    i = 2
    For Each item In jsonitems
        
        With rs
            
            ![INV] = item("INV")
            ![Customer] = item("Customer")
            ![TaxId] = item("TaxId")
            ![Address] = item("Address")
            ![InvoiceDate] = item("InvoiceDate")
            ![Product] = item("Product")
            ![Qty] = item("Qty")
            ![Price] = item("Price")
            ![VAT] = item("VAT")
            ![TotalPrice] = item("TotalPrice")
            End With
            jsonitems.Add jsonDictionery
            Set jsonDictionery = Nothing
            i = i + 1
    Next
    rs.Close
    Set rs = Nothing
    Set jsonitems = Nothing
    MsgBox JsonConverter.ConvertToJson(jsonitems, Whitespace:=3)
End Sub

Open in new window

Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
John TsioumprisSoftware & Systems Engineer

Commented:
Based on your code
jsonDictionery.Add "INV", item("INV")
jsonDictionery.Add "Customer", item("Customer")
...... Fill the rest

Open in new window

Sorry sir it is still showing nothing or empty message box

But the excel format works see the same code

Sub ConvertJson()
Dim excelRange As Range
Dim jsonItems As New Collection
Dim jsonDictionary As New Dictionary
Dim i As Long
Dim cell As Variant
Set excelRange = Cells(1, 1).CurrentRegion

For i = 2 To excelRange.Rows.Count
    jsonDictionary("id") = Cells(i, 1)
    jsonDictionary("name") = Cells(i, 2)
    jsonDictionary("username") = Cells(i, 3)
    jsonDictionary("email") = Cells(i, 4)
    jsonDictionary("street") = Cells(i, 5)
    jsonDictionary("suite") = Cells(i, 6)
    jsonDictionary("city") = Cells(i, 7)
    jsonDictionary("zipcode") = Cells(i, 8)
    jsonDictionary("phone") = Cells(i, 9)
    jsonDictionary("website") = Cells(i, 10)
    jsonDictionary("company") = Cells(i, 11)

    jsonItems.Add jsonDictionary
    Set jsonDictionary = Nothing
Next i

MsgBox ConvertToJson(jsonItems, Whitespace:=2)

End Sub

Open in new window



Customers-details.png
ste5anSenior Developer

Commented:
Correct. Cause in Excel you're writing into your dictionary, but in Access you're writing into your record set.

Thus the question: What is your data source in Access?
Should you be charging more for IT Services?

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!

Senior Developer
Commented:
btw, you have some flaws in your code.

Don't use Dim As New. Cause it has a weird behavior in the case of an exception, here these variables are reset.
Always use explicit column names as long as you don't have an specific requirement for dynamic column lists.

Thus I guess you need:

Private Sub CmdSales_Click()

  Const SQL_SELECT As String = "SELECT INV, Customer, TaxId, Address, InvoiceDate, Product, Qty, Price, VAT, TotalPrice FROM Qry1;"

  Dim coll As Scripting.Collection
  Dim dict As Scripting.Dictionary
  Dim db As DAO.Database
  Dim rs As DAO.Recordset
  Dim fld As DAO.Field

  Set coll = New Scripting.Collection
  Set db = CurrentDb
  Set rs = db.OpenReordset(SQL_SELECT, dbOpenSnapshot)
  If Not rs.Bof And Not rs.Eof Then
    Do While Not rs.Eof
      Set dict = New Scripting.Dictionary
      For Each fld In rs.Fields
        dict.Add fld.Name, rs.Fields(fld.Name)
      Next fld

      coll.Add dict
      rs.MoveNext
    Loop
  End If

  rs.Close
  Set fld = Nothing
  Set rs = Nothing
  Set db = Nothing
  Set dict = Nothing
  MsgBox JsonConverter.ConvertToJson(coll, Whitespace:=3)
  Set coll = Nothing

End Sub

Open in new window

Dear ste5an

Thank you so much for sporting the errors, however, I still have user defined not defined on

coll as scripting .collection

NewCollection.png
Top Expert 2014

Commented:
comment this line
Set jsonDictionary = Nothing

Open in new window

John TsioumprisSoftware & Systems Engineer

Commented:
If you have Scripting Runtime in the References check you will be OK
Clipboard01.jpgClipboard02.jpg
Dear ste5an;

Thank you so much for guiding to right direction, without your help I do not think that this issue will have been sorted out. But I have made a few change to code and has work very well:

Private Sub CmdSales_Click()
Const SQL_SELECT As String = "SELECT INV, Customer, TaxId, Address, InvoiceDate, Product, Qty, Price, VAT, TotalPrice FROM Qry1;"

  Dim coll As New Collection
  Dim dict As Scripting.Dictionary
  Dim db As DAO.Database
  Dim rs As DAO.Recordset
  Dim fld As DAO.Field

  Set coll = New Collection
  Set db = CurrentDb
  Set rs = db.OpenRecordset(SQL_SELECT, dbOpenSnapshot)
  If Not rs.BOF And Not rs.EOF Then
    Do While Not rs.EOF
      Set dict = New Scripting.Dictionary
      For Each fld In rs.Fields
        dict.Add fld.Name, rs.Fields(fld.Name)
      Next fld

      coll.Add dict
      rs.MoveNext
    Loop
  End If

  rs.Close
  Set fld = Nothing
  Set rs = Nothing
  Set db = Nothing
  Set dict = Nothing
  MsgBox JsonConverter.ConvertToJson(coll, Whitespace:=3)
  Set coll = Nothing
End Sub
ste5anSenior Developer

Commented:
Always specify the library where a class is defined:

Dim coll As VBA.Collection

Set coll = New VBA.Collection

Open in new window

When you want the default collection. Never let the compiler decide this. Cause in complex scenarios the order of resolution may change, thus your code can break. Happened in the past with Recordset (ADO vs DAO).
Top Expert 2014

Commented:
It would be better for you to clear the dictionary than to create a new one.

Use the RemoveAll method.
https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dictionary-object#methods
ste5anSenior Developer

Commented:
@Aikimark: Nope., not in this case. Collection.Add dict adds a reference not a value-copy.

 Capture.PNG
Option Explicit

Public Sub Test1()

  Dim coll As VBA.Collection
  Dim dict As Scripting.Dictionary

  Set coll = New VBA.Collection

  Set dict = New Scripting.Dictionary
  dict.Add "1", 1
  dict.Add "2", 2
  coll.Add dict
  Set dict = Nothing

  Set dict = New Scripting.Dictionary
  dict.Add "3", 3
  dict.Add "4", 4
  coll.Add dict
  Set dict = Nothing

  Set coll = Nothing

End Sub

Public Sub Test2()

  Dim coll As VBA.Collection
  Dim dict As Scripting.Dictionary

  Set coll = New VBA.Collection

  Set dict = New Scripting.Dictionary
  dict.Add "1", 1
  dict.Add "2", 2
  coll.Add dict

  dict.RemoveAll

  dict.Add "3", 3
  dict.Add "4", 4
  coll.Add dict
  Set dict = Nothing

  Set coll = Nothing

End Sub

Open in new window

Still I cannot get to work,

I have now run out of ideas.
ste5anSenior Developer

Commented:
Still I cannot get to work,
This does not tell us what your problem is. Especially as you wrote earlier:

But I have made a few change to code and has work very well:

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial