Excel VBAでJSONを自動生成（フラット定義版）

2023年2月25日
2023年2月25日
vba, システムエンジニアリング, 実装技術

vba

1 はじめに
2 サンプルExcelシートの説明
3 実現方式の説明
- 3.1 フィールド定義の解析方法
- 3.2 データモデル
4 ソースコードの説明

はじめに

シートに定義したフィールド名・型や値に基づいてJSONを生成するExcel VBAマクロを紹介します。
フィールド名は、”field1:field1-1:field1-1-1″等のように単一値でフラットに定義する想定です。（階層の区切り文字は既定で”:”としています。）
動作確認した環境は次の通りです。
OS Windows 10(64ビット)
Office Microsoft Office Professional Plus 2019
(Microsoft® Excel® 2019 MSO (16.0.14228.20216) 32 ビット )
マクロを含むExcelファイルをGitHubで公開しています。
こちらから直接ダウンロードすることもできます。
その他のサンプル
- フィールド定義が１階層前提の単純なサンプル
- Excelシート上に階層的に定義したフィールドからJSONを生成するサンプル

OS	Windows 10(64ビット)
Office	Microsoft Office Professional Plus 2019 (Microsoft® Excel® 2019 MSO (16.0.14228.20216) 32 ビット )

サンプルExcelシートの説明

Excelシート上に記載したフィールドや値をJSONに出力できます。
「配列」(E列)、「型」(F列)を変更することで、JSONへの値の出力仕様を変更できます。JSONにコメントを出力したい場合、「コメント」(H列)欄を指定します。「説明」(D列)、「備考」(I列)は、管理用に設けられた項目で処理に影響しません。

JSON出力の例は次の通りです。

{ "field1": 123, "field2": "abc", // コメントfield2 "field3": {  "field3-1": true }, "field4": {  "field4-1": "aaa",  "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] // コメントfield4-4-3  } }, "field5": false, "field7": 999, "field8": {  "field8-1": {"field8-1-1": false // 1階層飛ばし  } }, "field9": "最後"}

{

"field1": 123,

"field2": "abc", // コメントfield2

"field3": {

"field3-1": true

"field4": {

"field4-1": "aaa",

"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] // コメントfield4-4-3

}

"field5": false,

"field7": 999,

"field8": {

"field8-1": {

"field8-1-1": false // 1階層飛ばし

}

"field9": "最後"

}

詳細仕様
- フィールドの型として文字列(“string”)、数値(“number”)、真偽(“boolean”)、null(“null”)型を想定しています。
- 配列の指定がある場合、値をカンマで分割したものを値(指定された型を考慮)として使用します。
  例えば、配列・文字列型の値「123,456」は、「[“123”, “456”]」としてJSONに出力します。配列・数値型だった場合、「[123, 456]」としてJSONに出力します。
- 文字列や数値型の配列出力は可能ですが、JSONオブジェクトの配列出力は対応していません。
- 値が空のフィールドはスキップします。（ファイルへの出力対象外）

実現方式の説明

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

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

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

引数で指定された階層(ベースパス)にあるフィールドとその値等（フィールド定義）を抽出し、それらをリスト（フィールドリスト）として返却する再帰関数を定義します。
下位階層を持つフィールドが現れた場合、下位階層(ベースパス)を指定して同関数を実行します。返却されたフィールドリストを値として、当該フィールドをフィールドリストに追加します。
フィールドが下位階層を持つかどうかは、ベースパス以降のパス（処理対象パス）に階層の区切り文字であるコロンが含まれるかどうかで判定できます。

データモデル

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

ソースコードの説明

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

参照設定

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

メイン処理

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

'JSONデータを出力する。Public Sub OutputJsonData() 'ブックのドライブ・ディレクトリに移動 Dim path As String: path = ActiveWorkbook.path ChDrive path ChDir path Set gWs = ActiveSheet gRidx = RIDX_DATA_START  'フィールド定義の解析 Dim fieldDefs As Collection Set fieldDefs = ParseFields()  '解析結果に基づいてJSONを生成 Dim json As String json = CreateJson(fieldDefs)  'JSONをファイルに保存 Save OUTPUT_FILENAME, json  MsgBox OUTPUT_FILENAME & "に出力しました。" End Sub

'JSONデータを出力する。

Public Sub OutputJsonData()

'ブックのドライブ・ディレクトリに移動

Dim path As String: path = ActiveWorkbook.path

ChDrive path

ChDir path

Set gWs = ActiveSheet

gRidx = RIDX_DATA_START

'フィールド定義の解析

Dim fieldDefs As Collection

Set fieldDefs = ParseFields()

'解析結果に基づいてJSONを生成

Dim json As String

json = CreateJson(fieldDefs)

'JSONをファイルに保存

Save OUTPUT_FILENAME, json

MsgBox OUTPUT_FILENAME & "に出力しました。"

End Sub

フィールド定義の解析

フィールド定義の階層を再帰的に解析する関数を用意し、フィールドリストを生成します。
処理対象となる階層を「ベースパス」、それ以降のフィールドを「処理対象パス」とします。
例えば、フィールドが”field4:field4-2:field4-2-1″、ベースパスが”field4:”の場合、処理対象パスは”field4-2:field4-2-1″とします。
解析の中核となる再帰関数ParseFields()では、処理対象パスに含まれるフィールド数に基づいて、次のように処理を分岐します。
- フィールドの値の取得条件
  - 処理対象パスに単一フィールドのみを含む … 通常フィールドのため、「値」(G列)を値とする。
  - 処理対象パスに複数フィールドを含む … 再帰関数で取得したフィールドリストを値とする。
- 関数の終了条件
  - フィールドがベースパスを含まない … 処理中の階層ではないので現在の関数実行を終了し、生成したフィールドリストを呼出元に返却する。（このフィールドリストが呼出元のフィールドの値になる。）
再帰関数間での各種パラメータの引き渡しを簡略化するために、いくつかの変数はグローバル変数として宣言しています。
フィールド名を階層構造でなく１階層（フラット）で出力したい場合、定数IS_FLAT_JSONをTrueにします。（例えば、”field4:field4-2:field4-2-1″というフィールドを、そのまま”field4:field4-2:field4-2-1″というフィールド名としてJSONに出力したい場合。）

'フィールド開始行インデックスConst RIDX_DATA_START  As Integer = 6'列名Const COL_FIELD_NAME  As String = "C"Const COL_IS_ARRAY As String = "E"Const COL_TYPE  As String = "F"Const COL_VALUE As String = "G"Const COL_COMMENT  As String = "H"'フィールド型 ※実質的にstringのみ有効Const TYPE_STR As String = "string"Const TYPE_NUM As String = "number"Const TYPE_BOL As String = "boolean"'フィールド上の階層を表現する区切文字Const PATH_DELIMITER = ":"'動作制御Const IS_FLAT_JSON = False 'フラットで出力する場合はTrue'グローバル変数Dim gWs As Worksheet  '処理対象シートDim gRidx As Integer  '処理対象の行インデックス'フィールド定義を解析する。Private Function ParseFields(Optional basePath As String = "") Dim list As Collection: Set list = New Collection Do While True'ベースパスが異なる場合、このベースパスでの処理は終了  Dim fullPath As String: fullPath = gWs.Cells(gRidx, 3).Value  If fullPath = "" Or InStr(fullPath, basePath) <> 1 ThenSet ParseFields = listExit Function  End If '処理対象パス(ベースパス部分を削ったパス)を決定  '例: basePath="base1", fullPath="base1:f1:f1-1" -> targetPath="f1:f1-1"  Dim targetPath As String  If basePath <> "" ThentargetPath = Mid(fullPath, Len(basePath) + 1)  ElsetargetPath = fullPath  End If 'フィールド定義の生成(値がない場合はスキップ)  Dim fName As String  Dim deliIdx As Integer: deliIdx = InStr(targetPath, PATH_DELIMITER)  If IS_FLAT_JSON Or deliIdx = 0 Then'子フィールドなし(例: targetPath="f1")fName = targetPathDim def As FieldDef: Set def = CreateFieldDef(fName)If def.Value <> "" Then list.Add defEnd IfgRidx = gRidx + 1 '値が確定したので次の入力行に処理を移す  Else'子フィールドあり(例: targetPath="f1:f1-1")fName = Left(targetPath, deliIdx - 1)Dim newBasePath As String: newBasePath = Left(fullPath, Len(basePath) + deliIdx)Dim childList As Collection: Set childList = ParseFields(newBasePath)If childList.count > 0 Then '空の場合はスキップ list.Add CreateListFieldDef(fName, childList)End If'値が未確定なので現在の入力行を継続して処理対象とする  End If LoopEnd Function'フィールド定義を生成する。Function CreateFieldDef(fName As String, Optional list As Collection = Nothing) Dim fd As FieldDef: Set fd = New FieldDef fd.FieldName = fName fd.IsArray = gWs.Range(COL_IS_ARRAY & gRidx).Value fd.FieldType = gWs.Range(COL_TYPE & gRidx).Value fd.Comment = gWs.Range(COL_COMMENT & gRidx).Value fd.IsParent = False fd.Value = gWs.Range(COL_VALUE & gRidx).Value Set CreateFieldDef = fdEnd Function'リストを格納するフィールド定義を生成する。Function CreateListFieldDef(fName As String, list As Collection) Dim fd As FieldDef: Set fd = New FieldDef fd.FieldName = fName fd.IsParent = True Set fd.Value = list Set CreateListFieldDef = fdEnd Function

'フィールド開始行インデックス

Const RIDX_DATA_START As Integer = 6

'列名

Const COL_FIELD_NAME As String = "C"

Const COL_IS_ARRAY As String = "E"

Const COL_TYPE As String = "F"

Const COL_VALUE As String = "G"

Const COL_COMMENT As String = "H"

'フィールド型 ※実質的にstringのみ有効

Const TYPE_STR As String = "string"

Const TYPE_NUM As String = "number"

Const TYPE_BOL As String = "boolean"

'フィールド上の階層を表現する区切文字

Const PATH_DELIMITER = ":"

'動作制御

Const IS_FLAT_JSON = False 'フラットで出力する場合はTrue

'グローバル変数

Dim gWs As Worksheet '処理対象シート

Dim gRidx As Integer '処理対象の行インデックス

'フィールド定義を解析する。

Private Function ParseFields(Optional basePath As String = "")

Dim list As Collection: Set list = New Collection

Do While True

'ベースパスが異なる場合、このベースパスでの処理は終了

Dim fullPath As String: fullPath = gWs.Cells(gRidx, 3).Value

If fullPath = "" Or InStr(fullPath, basePath) <> 1 Then

Set ParseFields = list

Exit Function

End If

'処理対象パス(ベースパス部分を削ったパス)を決定

'例: basePath="base1", fullPath="base1:f1:f1-1" -> targetPath="f1:f1-1"

Dim targetPath As String

If basePath <> "" Then

targetPath = Mid(fullPath, Len(basePath) + 1)

Else

targetPath = fullPath

End If

'フィールド定義の生成(値がない場合はスキップ)

Dim fName As String

Dim deliIdx As Integer: deliIdx = InStr(targetPath, PATH_DELIMITER)

If IS_FLAT_JSON Or deliIdx = 0 Then

'子フィールドなし(例: targetPath="f1")

fName = targetPath

Dim def As FieldDef: Set def = CreateFieldDef(fName)

If def.Value <> "" Then

list.Add def

End If

gRidx = gRidx + 1 '値が確定したので次の入力行に処理を移す

Else

'子フィールドあり(例: targetPath="f1:f1-1")

fName = Left(targetPath, deliIdx - 1)

Dim newBasePath As String: newBasePath = Left(fullPath, Len(basePath) + deliIdx)

Dim childList As Collection: Set childList = ParseFields(newBasePath)

If childList.count > 0 Then '空の場合はスキップ

list.Add CreateListFieldDef(fName, childList)

End If

'値が未確定なので現在の入力行を継続して処理対象とする

End If

Loop

End Function

'フィールド定義を生成する。

Function CreateFieldDef(fName As String, Optional list As Collection = Nothing)

Dim fd As FieldDef: Set fd = New FieldDef

fd.FieldName = fName

fd.IsArray = gWs.Range(COL_IS_ARRAY & gRidx).Value

fd.FieldType = gWs.Range(COL_TYPE & gRidx).Value

fd.Comment = gWs.Range(COL_COMMENT & gRidx).Value

fd.IsParent = False

fd.Value = gWs.Range(COL_VALUE & gRidx).Value

Set CreateFieldDef = fd

End Function

'リストを格納するフィールド定義を生成する。

Function CreateListFieldDef(fName As String, list As Collection)

Dim fd As FieldDef: Set fd = New FieldDef

fd.FieldName = fName

fd.IsParent = True

Set fd.Value = list

Set CreateListFieldDef = fd

End Function

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

CreateJson関数で、フィールドリストを再帰的に辿って、フィールド・値をJSON形式で出力します。
このサンプルでは”//”形式のコメントを使用していますが、実行環境によってはエラーになる場合があります。コメントの出力を無効にする場合は定数OUTPUT_COMMENTの値をFalseにします。

'JSON出力時のインデントConst INDENT_PAD As String = " "'動作制御Const OUTPUT_COMMENT = True 'コメント出力しない場合はFalseConst IS_FLAT_JSON = False 'フラットで出力する場合はTrue'フィールド定義に基づいてJSONを再帰的に生成する。Private Function CreateJson(defs As Collection, Optional baseIndent As String = "")  'この関数で使用するインデント Dim curIndent As String: curIndent = baseIndent & INDENT_PAD  Dim body As String, keyval As String Dim i As Integer, def As FieldDef For i = 0 To defs.count - 1  Set def = defs(i + 1)'フィールド・値の生成  Dim val As String  If def.IsParent Thenval = CreateJson(def.Value, curIndent)  Elseval = CreateJsonValue(def)  End If  keyval = """" & def.FieldName & """: " & val '終端を考慮してコメントを追加  Dim lineComment As String: lineComment = CreateComment(def)  If i < defs.count - 1 Thenkeyval = keyval & "," & lineComment & vbCrLf  Elsekeyval = keyval & lineComment  End If body = body & curIndent & keyval Next CreateJson = "{" & vbCrLf & body & vbCrLf & baseIndent & "}"End Function'フィールド定義に基づいてJSON値を生成する。Function CreateJsonValue(def As FieldDef) Dim citing As String If def.FieldType = TYPE_STR Then  citing = """" Else  citing = "" End If If def.IsArray <> "" Then  CreateJsonValue = ArrayValues(def.Value, citing) Else  CreateJsonValue = citing & def.Value & citing End IfEnd Function'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'コメントを生成する。Function CreateComment(def As FieldDef) If OUTPUT_COMMENT And def.Comment <> "" Then  CreateComment = " // " & def.Comment End IfEnd Function

'JSON出力時のインデント

Const INDENT_PAD As String = " "

'動作制御

Const OUTPUT_COMMENT = True 'コメント出力しない場合はFalse

Const IS_FLAT_JSON = False 'フラットで出力する場合はTrue

'フィールド定義に基づいてJSONを再帰的に生成する。

Private Function CreateJson(defs As Collection, Optional baseIndent As String = "")

'この関数で使用するインデント

Dim curIndent As String: curIndent = baseIndent & INDENT_PAD

Dim body As String, keyval As String

Dim i As Integer, def As FieldDef

For i = 0 To defs.count - 1

Set def = defs(i + 1)

'フィールド・値の生成

Dim val As String

If def.IsParent Then

val = CreateJson(def.Value, curIndent)

Else

val = CreateJsonValue(def)

End If

keyval = """" & def.FieldName & """: " & val

'終端を考慮してコメントを追加

Dim lineComment As String: lineComment = CreateComment(def)

If i < defs.count - 1 Then

keyval = keyval & "," & lineComment & vbCrLf

Else

keyval = keyval & lineComment

End If

body = body & curIndent & keyval

CreateJson = "{" & vbCrLf & body & vbCrLf & baseIndent & "}"

End Function

'フィールド定義に基づいてJSON値を生成する。

Function CreateJsonValue(def As FieldDef)

Dim citing As String

If def.FieldType = TYPE_STR Then

citing = """"

Else

citing = ""

End If

If def.IsArray <> "" Then

CreateJsonValue = ArrayValues(def.Value, citing)

Else

CreateJsonValue = citing & def.Value & citing

End If

End Function

'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

ArrayValues = "[" & val & "]"

End Function

'コメントを生成する。

Function CreateComment(def As FieldDef)

If OUTPUT_COMMENT And def.Comment <> "" Then

CreateComment = " // " & def.Comment

End If

End Function