質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

87.37%

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

解決済

回答 3

投稿

  • 評価
  • クリップ 1
  • VIEW 10K+

score 20

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


よろしくお願いします。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 3

checkベストアンサー

+3

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

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2019/01/03 18:08

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

    出力結果が

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

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

    キャンセル

  • 2019/01/03 18:13 編集

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

    キャンセル

  • 2019/01/03 18:37

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

    キャンセル

+3

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"
    }
  ]
}

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2019/01/03 18:36

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

    キャンセル

  • 2019/01/03 18:41

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

    キャンセル

+1

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

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 87.37%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る