houghtonap
commented
3 years ago The following is a counter intuitive suggestion, which hopefully will become apparent. It sounds like the issue you are facing, given your current data structure, is that Json Arrays are stored as VBA.Collections and in order to access the items in a VBA.Collection you have to loop through the collection. Depending on your situation, this may be a simple loop to read the collection value and assign to an Excel cell which you have found to be too slow for your situation.
It is unfortunate that the VBA.Collection object does not have an Items method which returns a variant array of the collection's item values. However, we can make use of this feature of the Scripting.Dictionary object. As you may be aware, VBA-JSON uses the Scripting.Dictionary object to store a Json Object. Since you indicated that you have control over the Json being generated, you could change your Json to be:
{
"data": [
{ "1" : "header R1C1", "2" : "header R1C2", "3" : "header R1C3", "4" : "header R1C4", "5" : "header R1C5", "6" : "header R1C6" },
{ "1" : "value R2C1", "2" : "value R2C2", "3" : "value R2C3", "4" : "value R2C4", "5" : "value R2C5", "6" : "value R2C6" },
{ "1" : "value R3C1", "2" : "value R3C2", "3" : "value R3C3", "4" : "value R3C4", "5" : "value R3C5", "6" : "value R3C6" },
{ "1" : "value R4C1", "2" : "value R4C2", "3" : "value R4C3", "4" : "value R4C4", "5" : "value R4C5", "6" : "value R4C6" }
]
}How does this change to your Json help with your problem?
We basically have the following VBA object hierarchy:
Scripting.Dictionary ( holds the top-level Json Object )
VBA.Collection ( holds the "data" property value which is a Json Array )
Scripting.Dictionary ( holds the header values which are a Json Object )
Scripting.Dictionary ( holds the data values which are a Json Object )
Scripting.Dictionary ( holds the data values which are a Json Object )
Scripting.Dictionary ( holds the data values which are a Json Object )Once we have the "data" property's VBA.Collection we can simply loop through the collection and assign all the values to a group of cells using the Scripting.Dictionary object's Items method. Note, the Scripting.Dictionary object retrieves the values in the order of insertion which should be the order in which VBA-JSON parsed them.
Here is a simple VBA function that demonstrates this feature:
Public Function myCollection() As Variant
Dim dict As New Scripting.Dictionary
dict.Item("1") = "abc"
dict.Item("2") = "def"
dict.Item("3") = "ghi"
myCollection = dict.Items
Exit Function
End FunctionWhen you insert a new module into your Excel VBA project and add the above code, you now have a new formula function (UDF) available in the Excel spreadsheet. When you select $A1:$C1, then assign the array formula: =myCollection() followed by Ctrl-Shift-Enter keys, you should see the value: "abc", "def", "ghi" in $A1:$C1. So why does this work?
The Scripting.Dictionary object's Items method returns a VBA variant array of the item values in the dictionary. Since we used the myCollection() function in an Array Formula, the array will be placed in the selected cells $A1:$C1. When there are less values in the array than have been selected, e.g., $A1:$E1, Excel will place #N/A in the cell, otherwise when there are more values in the array than have been selected, e.g., $A1:$B1, Excel will only fill up to the selected range.
Applying this knowledge to VBA-JSON we basically wind up with the following VBA code for a macro that loads the values of the Json Objects that are contained in the "data" property's Json Array, into the active worksheet:
Public Sub LoadActiveSheet()
Const mesg As String = _
"{ " & _
"""data"" : [ " & _
"{ ""1"" : ""header R1C1"", ""2"" : ""header R1C2"", ""3"" : ""header R1C3"", ""4"" : ""header R1C4"", ""5"" : ""header R1C5"", ""6"" : ""header R1C6"" }, " & _
"{ ""1"" : ""value R2C1"", ""2"" : ""value R2C2"", ""3"" : ""value R2C3"", ""4"" : ""value R2C4"", ""5"" : ""value R2C5"", ""6"" : ""value R2C6"" }, " & _
"{ ""1"" : ""value R3C1"", ""2"" : ""value R3C2"", ""3"" : ""value R3C3"", ""4"" : ""value R3C4"", ""5"" : ""value R3C5"", ""6"" : ""value R3C6"" }, " & _
"{ ""1"" : ""value R4C1"", ""2"" : ""value R4C2"", ""3"" : ""value R4C3"", ""4"" : ""value R4C4"", ""5"" : ""value R4C5"", ""6"" : ""value R4C6"" } " & _
"] " & _
"}"
Dim ws As Worksheet ' Reference to Excel Worksheet object that will be used.
Dim json As Object ' Reference to object to the top level JSON.
Dim dict As Scripting.Dictionary ' Reference to the top level JSON Object.
Dim item As Object ' Reference to each JSON Object found in the "data" property.
Dim rows As VBA.Collection ' Reference to each JSON Object found in the "data" property's JSON Array.
Dim row As Long ' Number of rows in the "data" property's JSON Array.
Dim data As Scripting.Dictionary ' Reference to a JSON Object in the "data" property's JSON Array.
Dim dest As Excel.Range ' Destination range to write values.
Set ws = Excel.ActiveSheet ' Reference to the currently active worksheet.
Set json = ParseJson(mesg) ' Reference to the parsed Json which should be a JSON Object.
' Delete all cells on the active worksheet.
ws.Cells.Select
ws.Application.Selection.Delete Shift:=Excel.XlDirection.xlUp
' First let's make sure that the Json parsed was a Json Object.
' Note, depending on the API being used checking for a successful message could be much more
' complicated since the API could return a JSON Object for success and a JSON Array, Object,
' String, Boolean, Number, Null for an error.
If TypeOf json Is Scripting.Dictionary _
Then
' Reference for the top level JSON Object of the message.
' Strictly, you don't need to do this, but it does gives you intellisense.
Set dict = json
' Next let's make sure the "data" property exists in the message.
If dict.Exists("data") _
Then
' In VBA we cannot make the following TypeOf dict.Item("data") Is VBA.Collection part of the enclosing If statement's
' conditional because VBA does not perform short circuit evaluation of conditionals.
' See Wikipedia article: https://en.wikipedia.org/wiki/Short-circuit_evaluation
'
' In addition, when using the Scripting.Dictionary object you must test for the presence of the key
' *before** using the key, otherwise the Scripting.Dictionary object will **add** the key if it is
' not in the dictionary.
' See Remarks section: https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/item-property-dictionary-object
'
If TypeOf dict.item("data") Is VBA.Collection _
Then
' Reference for the "data" property's JSON Array.
' Strictly, you don't need to do this, but it does gives you intellisense.
Set rows = dict.item("data")
For row = 1 To rows.Count Step 1
' Retrieve an item from the JSON Array specified in the "data" property.
Set item = rows.item(row)
' Next let's make sure each item of the "data" property's JSON Array is a JSON Object.
If TypeOf item Is Scripting.Dictionary _
Then
' Reference for a JSON Object in the "data" property's JSON Array.
' Strictly, you don't need to do this, but it does gives you intellisense.
Set data = item
' Determine the range of cells to write values and write them to the active worksheet.
Set dest = ws.Cells(row, "A").Resize(1, data.Count)
dest.Value = data.Items
End If
Next row
End If
End If
End If
ws.Range("A1").Select
Exit Sub
End Sub
Hope that helps :octocat:
I am passing data through a web service that is formatted like below:
The way that this is parsed is as a collection of collections. Each inside collection represents a row of my data. I'd like to pull this out directly as 2d VBA array. The goal is to put the data into a sheet in my workbook, and looping through the collection-of-collections is far too expensive.
I have control over how the response is formatted from the server (within the constraints of having only the Python 2.7 STL to work with), so I'd be willing to format the JSON differently from the server if there is a method that would work.