【MOS】【Microsoft Office Excel】【マクロ/VBA】ExcelのリストをJSONに変換するマクロ

Sub make_json()
 
ThisWorkbook.Activate
'変数定義
    Const adTypeBinary = 1
    Const adTypeText = 2
    Const adSaveCreateOverWrite = 2
    
    Dim fileName, fileFolder, fileFile As String
    Dim isFirstRow As Boolean
    Dim i, u As Long
     
'最終行取得
    Dim maxRow, maxCol As Long
    If Len(ActiveSheet.Range("A2").Value) = 0 Then
        maxRow = 0
    ElseIf Len(ActiveSheet.Range("A3").Value) = 0 Then
        maxRow = 1
    Else
        maxRow = ActiveSheet.Range("A1").End(xlDown).Row
    End If
'最終列取得
    maxCol = Range("A1").End(xlToRight).Column
     
 
'JSONファイル定義
    fileName = ActiveSheet.Name            'JSONファイル名を指定
    fileFolder = ThisWorkbook.Path         '新しいファイルの保存先フォルダ名
    fileFile = fileFolder & "\" & fileName '新しいファイルをフルパスで定義
    
    '同名のJSONファイルが既にある場合は削除する
    If Dir(fileFile) <> "" Then
        Kill fileFile
    End If
 
'JSON作成
    'オブジェクトを用意する
    Dim txt As Object
    Set txt = CreateObject("ADODB.Stream")
    txt.Charset = "UTF-8"
    txt.Open
     
    'JSON開始タグ
    isFirstRow = True
    txt.Writetext "[" & vbCrLf, adWriteLine
     
    'リストをオブジェクトに書き込む
    For i = 2 To maxRow
        '1行目か確認して2行目以降の場合は行頭に","を挿入
        If isFirstRow = True Then
            isFirstRow = False
        Else
            txt.Writetext "," & vbCrLf, adWriteLine
        End If
         
        '行の開始タグを挿入
            txt.Writetext vbTab & "{" & vbCrLf, adWriteLine
         
            For u = 1 To maxCol
                '最終列でない場合は","を挿入
                If u = maxCol Then
                    txt.Writetext vbTab & vbTab & """" & Cells(1, u).Value & """" & ":" & """" & Cells(i, u).Value & """" & vbCrLf, adWriteLine
                Else
                    txt.Writetext vbTab & vbTab & """" & Cells(1, u).Value & """" & ":" & """" & Cells(i, u).Value & """" & "," & vbCrLf, adWriteLine
                End If
            Next u
         
        '行の閉じタグを挿入
        txt.Writetext vbTab & "}", adWriteLine
    Next
     
    'JSON終了タグ
    txt.Writetext vbCrLf, adWriteLine
    txt.Writetext "]" & vbCrLf, adWriteLine
     
    'BOMを削除する
    txt.Position = 0
    txt.Type = adTypeBinary
    txt.Position = 3
 
    Dim tmp() As Byte
    tmp = txt.Read
    txt.Close
 
    txt.Open
    txt.Write tmp
     
     
    'オブジェクトの内容をファイルに保存
    txt.SaveToFile fileFile, adSaveCreateOverWrite
     
    'オブジェクトを閉じる
    txt.Close
     
 
    MsgBox ("ファイルを生成しました｡")
     
 
End Sub

[
    {
        "num":"1",
        "name":"イチゴ",
        "url":"http://hoge.net"
    },
    {
        "num":"2",
        "name":"リンゴ",
        "url":""
    },
    {
        "num":"3",
        "name":"バナナ",
        "url":"http://hoge.com"
    }
]