VBAの連想配列のJSONの作成方法

Question

VBAをはじめて見たのですが、
VBA-JSONを用いて連想配列が作れなかった為
ご質問させてください。

作成したいJSONファイル

{
  "id" : 1,
  "shipTo" : { "name" : "テスト1",
               "address" : "東京",
               "zip"   : "150-0001" },
               { "name" : "テスト2",
               "address" : "大阪",
               "zip"   : "563-0000" }
}

サイト：
https://doruby.jp/users/ookouchi/entries/201708-EXCEL-VBA-JSON-API-MSXML2-XMLHTTP

上記のサイトを参考に
idに1をセットし,shiptoにname,address,zipをセット出来たのですが
その後ろに新たにテスト2を作りたいのですが、どのようにセットをすればいいでしょうか？

JsonObject.Add "data", New Collection
JsonObject.Add "contents", New Dictionary

のようにCollectionのなかにDictionaryを入れようとしたのですが
うまくいかなかったのでご教授ください。

![

試し中のソースコード

Option Explicit

Public Sub create_account()
    Dim company_name As String
    Dim confirm_key As String
    Dim contents As String
    Dim contents_body As String
    Dim JsonObject As Dictionary
    Dim json_data As String
    Dim account_txt As String
    Dim collumn_count As Long
    Dim record_count As Long
    Dim i As Long
    Dim j As Long
    
    collumn_count = Range("A1").End(xlToRight).Column  ' 列数をチェックする
    record_count = Range("A65536").End(xlUp).Row       ' 行数をチェックする
    
    Set JsonObject = CreateObject("Scripting.Dictionary")
    JsonObject.Add "data", New Collection
    JsonObject.Add "contents", New Dictionary
        
        For j = 1 To collumn_count
            For i = 1 To record_count
                JsonObject("contents").Add Cells(5, j), Cells(i, j)
            Next i
        JsonObject("data").Add JsonObject("contents")
        Next j
        
        json_data = JsonConverter.ConvertToJson(JsonObject, Whitespace:=2)
        MsgBox (json_data)
exit sub

よろしくお願いします。

Answer 1

Sub main()
    Dim JsonObject As Object
    Dim JsonItem As Object
    
    Set JsonObject = New Dictionary
    
    JsonObject.Add "id", 1
    JsonObject.Add "shipTo", New Collection

    For i = 2 To 3
        Set JsonItem = New Dictionary
        
        JsonItem.Add "name", Cells(i, 1).Value
        JsonItem.Add "address", Cells(i, 2).Value
        JsonItem.Add "zip", Cells(i, 3).Value
        
        JsonObject("shipTo").Add JsonItem
    Next
    
    ' イミディエイトウィンドウで確認（デバック用）
    Debug.Print JsonConverter.ConvertToJson(JsonObject, Whitespace:=2)
End Sub

出力結果

{
  "id": 1,
  "shipTo": [
    {
      "name": "\u30C6\u30B9\u30C81",
      "address": "\u6771\u4EAC",
      "zip": "150-0001"
    },
    {
      "name": "\u30C6\u30B9\u30C82",
      "address": "\u5927\u962A",
      "zip": "563-0000"
    }
  ]
}

Comments

[first_php]

ありがとうございます！
ベストアンサーが１人にしか上げれないのが悔やまれます・・・

[TanakaHiroaki]

大変勉強になる回答です。ありがとうございました。

Answer 2

VBAにて「CollectionのなかにDictionaryを入れる」を実現してみました。
なお、JsonConvertのテストは行っていないことをご承知おきください。
＜追記＞
Dic.RemoveAll　が空欄の原因となっていましたのでコードを修正しました。
JsonConvertのテストも実施済みです。

Sub create_account2()

    Dim company_name As String
    Dim confirm_key As String
    Dim contents As String
    Dim contents_body As String
    Dim JsonObject As Dictionary
    Dim json_data As String
    Dim account_txt As String
    Dim collumn_count As Long
    Dim record_count As Long
    Dim i As Long
    Dim j As Long

    collumn_count = Range("A1").End(xlToRight).Column  ' 列数をチェックする
    record_count = Range("A65536").End(xlUp).Row       ' 行数をチェックする

    Set JsonObject = CreateObject("Scripting.Dictionary")
    
'==ここから修正
    'Dictionaryの定義（配列を用いた）
    Dim Dic(1 To 2) As Object
    Set Dic(1) = CreateObject("Scripting.Dictionary")
    Set Dic(2) = CreateObject("Scripting.Dictionary")

    'Collectionの定義
    Dim Col As Collection
    Set Col = New Collection

    For i = 2 To record_count      'record_count =3
        For j = 1 To collumn_count 'collumn_count=3
            'Dictionaryにレコードを入れる
            Dic(i - 1).Add Cells(1, j).Value, Cells(i, j).Value
        Next j
        'CollectionにDictionaryオブジェクトを入れる
        Col.Add Dic(i - 1)
    Next i

    JsonObject.Add "id", 1
    JsonObject.Add "shipTo", Col
    
    Set Col = Nothing
'==ここまで修正

    json_data = JsonConverter.ConvertToJson(JsonObject, Whitespace:=2)
    MsgBox (json_data)

End Sub

Comments

[first_php]

３が日にわざわざ回答くださってありがとうございます！
おかげさまで、あともう一歩のところまで来ました！

出力結果が

{
"id": 1,
"shipTo": [
{
},
{
}
]
}

となっていたので、
Dic.RemoveAllをすると
collectionに格納したobjectが消えてしまったのかと
思って色々調べ中です！

[TanakaHiroaki]

Dic.RemoveAll　が空欄の原因となっていました。
コードを書き換えました。

[first_php]

おかげさまで、解決いたしました！
わざわざ書き換えまでしていただきありがとうございました！

Answer 3

user1さんのコードはすごいです。
お見事としか言いようがありません。