PeaceJetのブログ

金融系の社内エンジニアをやりながら、マーケティングやプランナーなども

【VBA】一つのカラム名に対して複数値のJSONを生成するコード

VBAJSONを生成したい

一つのカラム名に対して複数の値が存在するような場合について、JSONを生成するという需要がありましたので共有します。

例えば、Sheet1に以下のような値が入っているとします。

f:id:PeaceJet:20170425190901p:plain

この状態で、下記のような結果が欲しい場合は、これから紹介するコードが役に立つでしょう。

'以下のような、結果が返ります。
'{"ID":"1","NAME":"hoge","DETAIL":["fuga","fizz","buzz"]}


ただ、注意点があります。
それは、IDの列が2、3・・・と増加する場合の対応が出来ていないことです。

これは、Function名にJsonPostとあるように、VBAからPost送信をする際の使用を前提としているので、そこまでの機能拡張を視野に入れていないからです。

Jsonを送信するなら、この程度あれば十分かなということで作りました。

Function JsonPost()

    sName = "Sheet1"
    
    'Worksheetをセット
    Dim Ws As Worksheet: Set Ws = ThisWorkbook.Sheets(sName)
    'CurrentRegion
    Dim Region As Variant: Region = Ws.Cells(1, 1).CurrentRegion
    '行列の数
    Dim rLength, cLength As Long: rLength = UBound(Region, 1): cLength = UBound(Region, 2)
    
    '見出し
    ReDim Fields(cLength - 1)
    
    'データの取得とJSON生成
    Dim i As Long
    For i = 1 To cLength
        '1行目の各セルを見出しとして取得。
        Fields(i - 1) = Region(1, i)
    Next i
    
    Dim x, y As Long
    ReDim Temps(cLength - 1)
    
    For x = 1 To cLength
        
        Dim LastRows As Long: LastRows = Ws.Cells(100, x).End(xlUp).Row
        Dim FieldName As String: FieldName = Chr(34) & Fields(x - 1) & Chr(34) & ":"
        
        '値
        ReDim Values(LastRows - 2)
        For y = 2 To LastRows
            Values(y - 2) = Chr(34) & Ws.Cells(y, x) & Chr(34)
        Next y
        
        'DETAILの時は、配列にする。
        If FieldName = Chr(34) & "DETAIL" & Chr(34) & ":" Then
            Temps(x - 1) = FieldName & "[" & Join(Values, ",") & "]"
        Else
            Temps(x - 1) = FieldName & Join(Values, ",")
        End If

    Next x
    
    JsonPost = "{" & Join(Temps, ",") & "}"

End Function