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

'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

'フィールド開始行インデックス
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出力時のインデント
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
    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 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
    Next
    ArrayValues = "[" & val & "]"
End Function

'コメントを生成する。
Function CreateComment(def As FieldDef)
    If OUTPUT_COMMENT And def.Comment <> "" Then
        CreateComment = " // " & def.Comment
    End If
End Function