NDW

アプリ開発やトラブルシューティング等のノウハウ、キャンプや登山の紹介や体験談など。

1. システムエンジニアリング vba 実装技術

Excel VBAでJSONを自動生成

投稿日:2022年2月13日 更新日:

サンプルExcelシートの説明

  • Excelシート上に記載したフィールドや値をJSONに出力できます。
    「配列」(I列)、「型」(J列)を変更することで、JSONへの値の出力仕様を変更できます。JSONにコメントを出力したい場合、「コメント」(L列)欄を指定します。「説明」(H列)、「備考」(M列)は、管理用に設けられた項目で処理に影響しません。
  • JSON出力の例は次の通りです。
    // 作成日時: 2022/02/13 12:04:37
    {
        "field1": 123,
        "field2": "abc", // ラインコメントfield2
        // ブロックコメントfield3
        "field3": {
            "field3-1": true
        },
        "field4": {
            "field4-1": "aaa",
            // ブロックコメントfield4-2
            "field4-2": {
                "field4-2-1": ["A", "B", "C"],
                "field4-2-2": "XYZ"
            },
            "field4-3": true, // ラインコメントfield4-3
            "field4-4": {
                "field4-4-1": null,
                "field4-4-2": 111,
                "field4-4-3": [123, 456, 789] // カンマなしラインコメント
            }
        },
        "field5": false,
        "field7": "最後"
    }
    
  • 詳細仕様
    • フィールドの型として文字列(“string”)、数値(“number”)、真偽(“boolean”)、null(“null”)型を想定しています。
    • 配列の指定がある場合、値をカンマで分割したものを値(指定された型を考慮)として使用します。
      例えば、配列・文字列型の値「123,456」は、「[“123”, “456”]」としてJSONに出力します。配列・数値型だった場合、「[123, 456]」としてJSONに出力します。
    • 文字列や数値型の配列出力は可能ですが、JSONオブジェクトの配列出力は対応していません。
    • フィールドの種類に応じてJSONへのコメント仕様が異なります。
      当該フィールドが親フィールド(子となるフィールドを含む)の場合、当該フィールドの前の行にコメント(ブロックコメント)を出力します。当該フィールドが通常フィールドの場合、当該フィールドの後ろにコメント(ラインコメント)を出力します。
      {
          "field1": 111, // ラインコメント
          // ブロックコメント
          "field2": {
              "field2-1": 21,
              "field2-2": 22, // ラインコメント
          ...
      
  • 動作確認した環境は次の通りです。
    OS Windows 10(64ビット)
    Office Microsoft Office Professional Plus 2019
    (Microsoft® Excel® 2019 MSO (16.0.14228.20216) 32 ビット )
  • Excelファイルは、GitHubで公開しています。
    こちらから直接ダウンロードすることもできます。

実現方式の説明

Excelのシートに定義されたフィールドの階層構造の解析(「フィールド定義の解析」)と、解析結果に基づいてJSONデータを作成する処理(「解析結果に基づいたJSONの生成」)に分割して実現しています。ここでは、実現方法の難易度が高めの「フィールド定義の解析」について説明します。

フィールド定義の解析方法

再帰関数を定義して階層構造を解析します。

  • 引数で指定された階層(N)にあるフィールドとその値等(フィールド定義)を抽出し、それらをリスト(フィールドリスト)として返却する再帰関数を定義します。
  • 下位階層(N+1)を持つフィールドが現れた場合、下位階層(N+1)を指定して同関数を実行します。返却されたフィールドリストを値として、当該フィールドをフィールドリストに追加します。
  • フィールドが下位階層を持つかどうかは、次の行にあるフィールドの階層(列位置)で判定できます。

データモデル

  • フィールド定義(フィールド名、型、値等)は、独自に定義したFieldDef型(クラス)に格納します。これらを格納するフィールドリストとしてCollection型を使用します。
  • 前節の階層構造に対応するデータモデルの例(主要プロパティのみ記載)を次に示します。
    フィールドの値が数値や文字列の場合、Valueプロパティにその値を設定します。下位階層があるフィールドの場合、Valueプロパティに下位階層のフィールドリスト、子のフィールドリストがあることを示すためのプロパティIsParentにtrue、を設定しています。

ソースコードの説明

メイン処理、フィールド定義の解析、JSONの生成処理について説明します。
完全なソースコードは、Excelファイルをダウンロードしてご確認ください。

参照設定

  • JSONをUTF-8形式でファイルに保存するために、”Microsoft ActiveX Data Objects 6.1 Library”を使用しています。[ツール] – [参照設定]で当該ライブラリを追加してください。

メイン処理

  • 後述の「フィールド定義の解析」「解析結果に基づいたJSONの生成」を実行します。
  • フィールド定義の解析結果はフィールドリスト(FieldDefs型を要素とするCollectionクラス)に格納しています。
Public Sub OutputJsonData()

    'ブックのドライブ・ディレクトリに移動
    Dim path As String: path = ActiveWorkbook.path
    ChDrive path
    ChDir path

    'フィールド定義の解析
    Dim fieldDefs As Collection
    Set fieldDefs = ParseFields()
    
    '解析結果に基づいてJSONを生成
    Dim json As String
    json = CreateJsonData(fieldDefs)
    
    'JSONをファイルに保存
    Save OUTPUT_FILENAME, json
    
    MsgBox OUTPUT_FILENAME & "に出力しました。"
    
End Sub

フィールド定義の解析

  • フィールド定義の階層を再帰的に解析する関数を用意し、フィールドリストを生成します。
  • ここでは便宜上、文字列/数値/配列型の値を持つフィールドを「通常フィールド」、子のフィールド(オブジェクト)を持つフィールドを「親フィールド」と表記しています。
  • 解析の中核となる再帰関数ParseChildFields()では、処理中の次のフィールドの階層(列)に基づいて、次のように処理を分岐します。
    • フィールドの値の取得条件
      • 次のフィールドの階層(nextDepth ) ≦ 処理中の階層(depth) … 通常フィールドのため、「値」(K列)を値とする。
      • 処理中の階層(depth) ≦ 次のフィールドの階層(nextDepth ) … 親フィールドのため、再帰関数で取得したフィールドリストを値とする。
    • 関数の終了条件
      • 次のフィールドの階層(nextDepth ) < 処理中の階層(depth) … 処理中の階層(depth)の最終フィールドなので現在の関数実行を終了し、生成したフィールドリストを呼出元に返却する。(このフィールドリストが呼出元の親フィールドの値になる。)
  • 再帰関数間での各種パラメータの引き渡しを簡略化するために、いくつかの変数はグローバル変数として宣言しています。
'フィールド開始行インデックス
Const RIDX_DATA_START  As Integer = 6

'列名
Const COL_FIELD_START As String = "C"
Const COL_FIELD_END   As String = "G"
Const COL_IS_ARRAY    As String = "I"
Const COL_TYPE        As String = "J"
Const COL_VALUE       As String = "K"
Const COL_COMMENT     As String = "L"

'グローバル変数
Dim gWs As Worksheet           '処理対象シート
Dim gRidx As Integer           '処理対象の行インデックス
Dim gMaxRidx As Integer        '最大行インデックス
Dim gFieldStartCidx As Integer 'フィールド開始列インデックス
Dim gMaxDepth As Integer       '最大階層

'フィールド定義を解析する。
Private Function ParseFields()

    'グローバル変数の初期化
    Set gWs = ActiveSheet
    gRidx = RIDX_DATA_START
    gMaxRidx = gWs.UsedRange.Rows(gWs.UsedRange.Rows.Count).Row
    gFieldStartCidx = ColToIdx(COL_FIELD_START)
    gMaxDepth = ColToIdx(COL_FIELD_END) - gFieldStartCidx
    
    '再帰的にJSONの階層を解析
    Set ParseFields = ParseChildFields()

End Function

'フィールド定義を再帰的に解析する。
Private Function ParseChildFields(Optional depth As Integer = 0)

    Dim defs As Collection: Set defs = New Collection
    Set ParseChildFields = defs '戻り値
    
    Dim curCidx As Integer: curCidx = gFieldStartCidx + depth
    Do While gRidx < gMaxRidx
        
        'フィールドの定義情報を取得
        Dim fname As String: fname = gWs.Cells(gRidx, curCidx).Value
        Dim isa As String: isa = gWs.Range(COL_IS_ARRAY & gRidx).Value
        Dim ftype As String: ftype = gWs.Range(COL_TYPE & gRidx).Value
        Dim val As String: val = gWs.Range(COL_VALUE & gRidx).Value
        Dim cmt As String: cmt = gWs.Range(COL_COMMENT & gRidx).Value
        
        If fname = "" Then RaiseError "フィールドが未定義です。"
        
        '通常フィールドか親フィールドかを次行のフィールド階層で判定
        Dim nextDepth As Integer: nextDepth = GetNextDepth()
        If nextDepth <= depth Then
            '次行が同階層or上位階層の場合、通常フィールドとして値を保持
            If val <> "" Then '空値フィールドは除外
                Dim vf As FieldDef: Set vf = New FieldDef
                vf.FieldName = fname
                vf.IsArray = isa
                vf.FieldType = ftype
                vf.Value = val
                vf.Comment = cmt
                vf.IsParent = False
                defs.Add vf
            End If
        ElseIf depth + 1 = nextDepth Then
            '次行が下位階層の場合、親フィールドとして下位階層の定義を再帰取得
            gRidx = gRidx + 1
            Dim values As Collection: Set values = ParseChildFields(depth + 1)
            If values.Count > 0 Then '空リストは除外
                Dim pf As FieldDef: Set pf = New FieldDef
                pf.FieldName = fname
                Set pf.Value = values
                pf.Comment = cmt
                pf.IsParent = True
                defs.Add pf
            End If
            '再帰処理で現在行が進んでいるので最新化
            nextDepth = GetNextDepth()
        Else
            '次行が1階層以上飛ばした下位階層の場合はエラー
            RaiseError "想定する階層と異なります。", gRidx + 1
        End If
        
        '次行が上位階層の場合、この階層の処理は終了(空行の場合は終了とみなす)
        If nextDepth < depth Then Exit Function
        
        gRidx = gRidx + 1
    Loop

End Function

'処理行の次の行で定義されるフィールドの階層(深さ)を取得する。
Private Function GetNextDepth()
    Dim i As Integer
    For i = 0 To gMaxDepth - 1
        If gWs.Cells(gRidx + 1, gFieldStartCidx + i).Value <> "" Then
            GetNextDepth = i
            Exit Function
        End If
    Next
    GetNextDepth = -1
End Function

解析結果に基づいたJSONの生成

  • フィールドリストを再帰的に辿って、フィールド・値をJSON形式で出力します。
  • JSON生成の中核となるのは再帰関数CreateChildJsonData()です。フィールド定義(FieldDef型)にある配列や型に基づいて、フィールドに対応する値を生成します。
  • このサンプルでは”//”形式のコメントを使用していますが、実行環境によってはエラーになる場合があります。
  • JSONファイルの先頭に追加するコメント(ヘッダコメント)をEditHeaderComment()関数で生成しています。
    生成したJSONファイルをバージョン管理する場合、生成元となったExcelファイルとの対応が分かるよう、ヘッダコメントにExcelファイルのバージョンを識別できるような情報(Excel上の改定履歴版やバージョン管理システムのリビジョン情報等)の埋め込みをお薦めします。
  • コメントの出力内容や条件を変更したい場合、EditHeaderComment(), EditFieldComment()の内容を変更してください。
'フィールド型 ※実質的にstringのみ有効
Const TYPE_STR As String = "string"
Const TYPE_NUM As String = "number"
Const TYPE_BOL As String = "boolean"

'JSON出力時のインデント
Const INDENT_PAD As String = "    "

'フィールド定義に基づいてJSONデータを生成する。
Private Function CreateJsonData(defs As Collection)
    
    'JSONの最初に追加するコメント
    Dim header As String: header = EditHeaderComment()
    
    'フィールド定義に基づいて再帰的にJSONデータを作成
    Dim body As String
    body = CreateChildJsonData(defs)
    
    CreateJsonData = _
        header & _
        "{" & vbCrLf & _
        body & vbCrLf & _
        "}"

End Function

'フィールド定義に基づいてJSONデータを再帰的に生成する。
Private Function CreateChildJsonData( _
    defs As Collection, Optional baseIndent As String = "")
    
    'この関数で使用するインデント
    Dim curIndent As String: curIndent = baseIndent & INDENT_PAD
    
    Dim body As String, keyVal As String
    Dim blockComment As String, lineComment As String
    Dim i As Integer, def As FieldDef
    For i = 0 To defs.Count - 1
        Set def = defs(i + 1)
    
        'フィールド・値の生成
        If Not def.IsParent Then
            'フィールドが値の場合、型や配列指定に応じて出力
            Dim val As String, citing As String
            If def.FieldType = TYPE_STR Then
                citing = """"
            Else
                citing = ""
            End If
            If def.IsArray <> "" Then
                val = ArrayValues(def.Value, citing)
            Else
                val = citing & def.Value & citing
            End If
            keyVal = curIndent & """" & def.FieldName & """: " & val
        Else
            '親フィールドの場合、再帰的にJSONを生成した結果を出力
            Dim vals As String: vals = CreateChildJsonData(def.Value, curIndent)
            keyVal = _
                curIndent & """" & def.FieldName & """: {" & vbCrLf & _
                vals & vbCrLf & _
                curIndent & "}"
        End If
        
        '終端を考慮してコメントを追加
        EditFieldComment def, curIndent, blockComment, lineComment
        If blockComment <> "" Then keyVal = blockComment & vbCrLf & keyVal
        If i < defs.Count - 1 Then
            keyVal = keyVal & "," & lineComment & vbCrLf
        Else
            keyVal = keyVal & lineComment
        End If
        
        body = body & keyVal
    Next
    CreateChildJsonData = body
End Function

'JSONの先頭に付与するコメントを編集する。
Private Function EditHeaderComment()
    EditHeaderComment = "// 作成日時: " & Now & vbCrLf
End Function

'フィールド用コメントを編集する。
Private Sub EditFieldComment(def As FieldDef, indent As String, _
    ByRef blockComment As String, ByRef lineComment As String)
    
    blockComment = ""
    lineComment = ""
    If def.Comment = "" Then Exit Sub
    
    '親フィールドの場合は行前、通常フィールドの場合は行末
    Dim cm As String: cm = "// " & def.Comment
    If def.IsParent Then
        blockComment = indent & cm
    Else
        lineComment = " " & cm
    End If
End Sub

'JSON配列値を生成する。
Private Function ArrayValues(rawVal As String, Optional citing As String = "")
    Dim val As String, v As Variant
    Dim vals() As String: vals = Split(rawVal, ",")
    For Each v In vals
        If Len(val) > 0 Then val = val & ", "
        val = val & citing & Trim(v) & citing
    Next
    ArrayValues = "[" & val & "]"
End Function






-1. システムエンジニアリング, vba, 実装技術

関連記事

wildflyへのwarデプロイの自動化

更新したWebアプリをWildflyにデプロイするのが面倒なのでスクリプトを作成してみました。 前提 実行環境はCentOS Linux 7です。 JavaEEのWebアプリの配布形式であるwarファ …

ASP.NET Core: IHttpClientFactoryの使用方法

とりあえず、どんなサンプルになるか知りたい人は下記のサンプルをご覧ください。 ASP.NET Core: IHttpClientFactoryの単純サンプル ASP.NET Core: IHttpCl …

テキストファイルマスクツール

本番環境での性能検証でNGになってしまった。 どの処理でどれほどの処理時間がかかっているかを把握するためにログレベルを変更して、ログを取得した。 対応方法を自社の担当者と検討するために、本番環境からこ …

OWASPが推奨する強力なパスワード

Webアプリケーションのセキュリティの標準化や推進を行うOWASPでは、強力なパスワードの使用を推奨しているので、それをまとめた。 cheatsheetseries.owasp.org  1 …

Graph API実行環境の準備方法(クライアント資格情報フローのアプリ登録)

概要 WebアプリからGraphAPIを使用してAzure AD B2C上のユーザアカウントの操作を行うことを想定しています。このような構成でGraph APIを使用できるようにするためのAzure …