Excel VBAでJSONを自動生成

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

vba

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

はじめに

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

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

サンプル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": "最後"}

// 作成日時: 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, // ラインコメント ...

{

"field1": 111, // ラインコメント

// ブロックコメント

"field2": {

"field2-1": 21,

"field2-2": 22, // ラインコメント

...

実現方式の説明

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

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_ENDAs 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 vfEnd If  ElseIf depth + 1 = nextDepth Then'次行が下位階層の場合、親フィールドとして下位階層の定義を再帰取得gRidx = gRidx + 1Dim 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 pfEnd If'再帰処理で現在行が進んでいるので最新化nextDepth = GetNextDepth()  Else'次行が１階層以上飛ばした下位階層の場合はエラーRaiseError "想定する階層と異なります。", gRidx + 1  End If '次行が上位階層の場合、この階層の処理は終了(空行の場合は終了とみなす)  If nextDepth < depth Then Exit Function gRidx = gRidx + 1 LoopEnd Function'処理行の次の行で定義されるフィールドの階層(深さ)を取得する。Private Function GetNextDepth() Dim i As Integer For i = 0 To gMaxDepth - 1  If gWs.Cells(gRidx + 1, gFieldStartCidx + i).Value <> "" ThenGetNextDepth = iExit Function  End If Next GetNextDepth = -1End Function

100

101

102

103

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

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

'次行が１階層以上飛ばした下位階層の場合はエラー

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

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 StringIf def.FieldType = TYPE_STR Then citing = """"Else citing = ""End IfIf def.IsArray <> "" Then val = ArrayValues(def.Value, citing)Else val = citing & def.Value & citingEnd IfkeyVal = 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 ThenkeyVal = keyVal & "," & lineComment & vbCrLf  ElsekeyVal = keyVal & lineComment  End If body = body & keyVal Next CreateChildJsonData = bodyEnd Function'JSONの先頭に付与するコメントを編集する。Private Function EditHeaderComment() EditHeaderComment = "// 作成日時: " & Now & vbCrLfEnd 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 IfEnd 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

100

101

102

103

104

105

106

107

108

109

'フィールド型 ※実質的に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

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

ArrayValues = "[" & val & "]"

End Function