VBAによるJSONファイル生成

---

UTF8によるデータ出力

Sub Create_JSON()
    Dim FileName As String
    Dim isFirstRow As Boolean
    Dim row, col As Integer
    'シート名としてdataを指定...
    Sheets("data").Select
    'A1セルのチェック...
    If WorksheetFunction.CountA(Cells(1, 1)) = 0 Then
        MsgBox "A1セルにデータがありません。中止します。", vbCritical
        Exit Sub
    End If
    '行数と列数を得る...
    row = Range("A1").EntireColumn.SpecialCells(xlCellTypeConstants).Count
    col = Range("A1").EntireRow.SpecialCells(xlCellTypeConstants).Count
    ' 保存先を指定する
    FileName = Application.GetSaveAsFilename
    If Dir(FileName) <> "" Then
        rc = MsgBox("既にファイルがあります。既にあるファイルを削除して新たに作成しますか？", vbYesNo + vbQuestion)
        If rc = vbNo Then
            MsgBox "処理を中止します", vbCritical
            Exit Sub
        Else
            'ファイルを削除する...
            Kill FileName
        End If
    End If
    'ここからUTF-8で保存する...
    Dim txt As Object
    Set txt = CreateObject("ADODB.Stream")
    'オブジェクトに保存するデータの種類を文字列型に指定する
    'txt.Type = adTypeText
    '文字列型のオブジェクトの文字コードを指定する
    txt.Charset = "UTF-8"
    'オブジェクトのインスタンスを作成
    txt.Open
    ' 1行目のフラグを設定する
    isFirstRow = True
    'はじめの[を記載する...
    txt.WriteText "[" & vbCrLf, adWriteLine
    '配列をオブジェクトに書き込む
    For rc = 2 To row
            ' 1行目か確認する．1行目の場合だけは行頭に","を入力しない
            If isFirstRow = True Then
                ' 1行目フラグをFalseし,以降行頭に","を入力するようにする
                isFirstRow = False
            Else
                txt.WriteText vbTab & "," & vbCrLf, adWriteLine
            End If
            ' データ要素の開始記号を入力
            txt.WriteText vbTab & "{" & vbCrLf, adWriteLine
            '' 列の繰り返し．データは必ず3列目から入力されている想定
            For cc = 1 To col
                    ' 最後のデータであるか確認する
                    If cc = col Then
                        ' 最後のデータである場合には","不要
                        txt.WriteText vbTab & vbTab & """" & Cells(1, cc).Value & """:" & vbTab & """" & Cells(rc, cc).Value & """" & vbCrLf, adWriteLine
                    Else
                        ' 次に入力するデータがある場合には","を入力する
                        txt.WriteText vbTab & vbTab & """" & Cells(1, cc).Value & """:" & vbTab & """" & Cells(rc, cc).Value & """" & "," & vbCrLf, adWriteLine
                    End If
            Next
            ' データ要素終了記号を入力
            txt.WriteText vbTab & "}", adWriteLine
    Next
    txt.WriteText "]" & vbCrLf, adWriteLine
    'オブジェクトの内容をファイルに保存
    txt.SaveToFile FileName
    'オブジェクトを閉じる
    txt.Close
    MsgBox ("出力完了")
    '保存したフォルダを開く...
    Dim PathName As String, pos As Long
    pos = InStrRev(FileName, "\")
    PathName = Left(FileName, pos)
    Shell "C:\Windows\Explorer.exe " & PathName, vbNormalFocus
End Sub

            

---