NDW*

ExcelをCSV, SQL文, JSONに簡単変換(VBA)

vba
目次

はじめに

  • 業務作業の中で、リストやCSV、Excelのデータを要件に基づいて大量に変換したい場合があります。ここでは、可能な限り簡単にデータの変換を行うためのExcel VBAのサンプルを紹介します。
  • ここで紹介するサンプルは、ちょっとした業務作業の効率化のために簡単に変更して使えることを目標にしており、可能な限り短く分かりやすいコードにしています。業務要件で求められるようなエラーハンドリング等の考慮はしていないことにご注意ください。
  • ここで紹介するサンプルは、Windows 10(64ビット)のExcel 2019(32ビット)で動作確認しています。

スクリプト概要

  • シート上のデータを行単位に読み取り、その内容を編集した結果をファイルに出力します。

    • 行の内容に基づいてファイルに出力する内容を編集する行編集関数を用意しています。要件に一番近い行編集関数を呼び出すよう変更し、その行編集関数の内容を要件に合わせて変更してください。
      行編集関数の名称説明
      CSV
      (ProcessRowAsCsv関数)      		ヘッダ行を含むCSVレコードを生成します。ヘッダ行の列、データ行の値は全て引用符付きで出力します。
      テキスト
      (ProcessRowAsTxt関数)      		データ行からコマンドテキストを作成します。出力内容はサンプル（イメージ）です。
      （単純なコマンドであればExcel関数式の方が早いかもしれません。）
      SQL
      (ProcessRowAsSql関数)      		SQLのINSERT文を生成します。
      JSON
      (ProcessRowAsJsn関数)      		JSONを生成します。（各行データをJSONオブジェクト要素とする配列形式）
    • Windows環境での出力ファイルのエンコーディングはShift_JISです。サンプルを修正して、UTF-8に変更することもできます。
  • コピペして最小限の設定で実行できるようになっています。

    • 処理対象となるデータを含むExcel(VBA)にスクリプトを張り付け、「ヘッダ行数」「データ領域」等を変更し、実行するだけです。（xls,xlsxファイルに張り付けて実行することも可能ですが、保存する場合はxlsm形式が必要です。）
    • VBAの編集画面はショートカット「Alt + F11」で開けます。
      メニューから開く場合、[オプション]－[リボンのユーザー設定]で開発タブを表示し、”Visual Basic”をクリックします。詳細はこちらをご覧ください。
  • スクリプトの基本となる考えや処理の概要は次の通りです。

    • ヘッダ行とデータ行を特定し、データ行の行毎に行編集関数ProcessRowAsXXX()を実行します。
    • 定数DataStartA1, DataEndA1に指定された範囲をデータ行とします。ヘッダ行の直前N行（定数HeadRowCount）をヘッダ行とします。
    • ProcessRowAsXXX()の引数として「ヘッダ行」（範囲）、「データ行」（範囲）、「処理対象の行番号」（整数）が渡されます。この関数の返却値がファイルに出力されます。
    • ヘッダ・フッタデータを作成する関数の作成も考えたのですが、関数が複数に分かれると切替が面倒なので、必要であれば行編集関数でヘッダ・フッタを出力する設計にしています。

スクリプト内容

Excel VBAスクリプトの説明です。
完全なソースコードはgithub（「簡単変換サンプル.xlsm」）で公開しています。

基本部分と行編集関数：CSV

  • スクリプトの主要な処理のスクリプトは次の通りです。
    （例としてCSVを出力する行編集関数を含んでいます。）

    Option Explicit '誤動作防止のため

Const HeadRowCount = 2       '★ヘッダ行数
Const DataStartA1 = "B5"     '★データ領域(左上)
Const DataEndA1 = ""         '★データ領域(右下) ※未指定時は自動検出

Const OutputFile = ".\output.txt"  '★出力先 ※カレントはBookのパス

Sub Main()
    GenerateFile Worksheets("Sheet1") '★シート名
End Sub

Sub GenerateFile(ws As Worksheet)
    
    ws.Activate 'コード簡潔化のために処理対象シートを選択
    
    ChDir ThisWorkbook.Path: ChDrive ThisWorkbook.Path
    Open OutputFile For Output As #1 'Windows環境だとSJIS
    
    'データ行リスト、ヘッダ行リストを生成
    Dim dataRange As Range, dataRows As Range, headRows As Range
    Set dataRange = DetectDataRange()
    Set dataRows = dataRange.Rows
    Set headRows = dataRange.Offset(-HeadRowCount, 0).Rows("1:" & HeadRowCount)
    
    'データ行の行単位で処理
    Dim rowIdx As Integer, line As String, genCount As Integer
    For rowIdx = 1 To dataRows.Rows.Count
        '★要件に近い行編集関数のコメントアウトは外す
        line = ProcessRowAsCsv(headRows, dataRows, rowIdx)
        'line = ProcessRowAsTxt(headRows, dataRows, rowIdx)
        'line = ProcessRowAsSql(headRows, dataRows, rowIdx)
        'line = ProcessRowAsJsn(headRows, dataRows, rowIdx)
        If line <> "" Then
            Print #1, line
            genCount = genCount + 1
        End If
    Next
    Close #1
    'ResaveAsUtf8 OutputFile 'UTF-8で保存し直す
    
    MsgBox genCount & "件を出力しました。"
    'Shell "notepad.exe " & OutputFile, vbNormalFocus 'アプリ起動例
End Sub

'データ領域の特定
Function DetectDataRange()
    Dim endA1 As String: endA1 = DataEndA1
    If endA1 = "" Then
        With UsedRange
            endA1 = .Cells(.Rows.Count, .Columns.Count).Address(False, False)
        End With
    End If
    Set DetectDataRange = Range(DataStartA1 & ":" & endA1)
End Function

'行編集関数: CSV
Function ProcessRowAsCsv(headRows As Range, dataRows As Range, rowIdx As Integer)
    
    Dim line As String, colIdx As Integer, deli As String
    
    '先頭行の場合はヘッダを含める
    If rowIdx = 1 Then
        For colIdx = 1 To headRows.Columns.Count
            If colIdx = 1 Then deli = "" Else deli = ","
            line = line & deli & """" & headRows.Cells(1, colIdx) & """"
        Next
        line = line & vbCrLf
    End If
    
    '行頭(キー)が空の場合はスキップ
    If dataRows.Cells(rowIdx, 1) = "" Then Exit Function
    
    For colIdx = 1 To headRows.Columns.Count
        If colIdx = 1 Then deli = "" Else deli = ","
        line = line & deli & """" & dataRows.Cells(rowIdx, colIdx) & """"
    Next
    
    ProcessRowAsCsv = line
End Function
  • カスタマイズのポイント
    行番号説明
    3-5シートの内容に応じて、ヘッダ行数（定数HeadRowCount）、データ領域（定数DataStartA1、定数DataEndA1）を変更してください。DataEndA1はシートの使用範囲から自動的に決定されますが、変更したい場合は値を指定してください。
    7実行結果は、VBAを張り付けたExcelブックと同じフォルダにoutput.txtとして出力されます。出力先を変更する場合は、定数OutputFileを変更してください。
    10シート名を変更してください。
    30-32要件に近い行編集関数が実行されるよう、不要な行編集関数をコメントアウトしてください。
    39Windows環境ではShift_JISで保存します。UTF-8で保存したい場合、ResaveAsUtf8関数を実行するようコメントアウトを外してください。
    42ファイル作成後にコマンドを実行したい場合、Shell関数が実行されるようコメントアウトを外して、希望のコマンドを指定してください。
    57-79ヘッダ行、データ行の全ての項目を引用符付きで出力する実装になっています。要件に応じて変更してください。

行編集関数：テキスト

  • コマンド等の任意のテキストを生成するための行編集関数です。
    • シート上の複数列の値に基づいて内容に基づいて、コマンド等を作成する際に使用する想定です。
    • サンプルで出力しているコマンドテキストはサンプルであり特に意味はありません。
    • 私の業務作業で、Azure上の多数のリソースの作成や変更を行う場合があります。対象リソースや条件をシートに記載し、纏めてPowerShellコマンドを作成する際に使用する想定です。
    '行編集関数: テキスト
Function ProcessRowAsTxt(headRows As Range, dataRows As Range, rowIdx As Integer)
    
    If dataRows.Cells(rowIdx, 1) = "" Then Exit Function
    
    Dim keyName As String: keyName = dataRows.Cells(rowIdx, 2)
    ProcessRowAsTxt = "findstr /S """ & keyName & """ *.txt"
    
End Function

行編集関数：SQL

  • SQLのINSERT文を作成する行編集関数です。
    • 18行目の変数tableのテーブル名を適宜変更してください。シート名から取得する場合、”ActiveSheet.Name”を代入してください。
    • INSERT文に出力する値を編集したい場合、EditSqlVal()の内容を変更してください。
    • EditSqlVal()では、char/varchar/nchar/nvarchar/text等の文字列型、date/time/datetime等の日付・時刻型では引用符付きで値を出力します。
    '行編集関数: SQL
Function ProcessRowAsSql(headRows As Range, dataRows As Range, rowIdx As Integer)
    
    If dataRows.Cells(rowIdx, 1) = "" Then Exit Function
    
    'insert文の列名と値に対応する文字列生成
    Dim colIdx As Integer, cols As String, vals As String
    Dim colName As String, colType As String, val As String, deli As String
    For colIdx = 1 To dataRows.Columns.Count
        colName = headRows.Cells(1, colIdx)
        colType = headRows.Cells(2, colIdx)
        val = EditSqlVal(colName, colType, dataRows.Cells(rowIdx, colIdx))
        If colIdx = 1 Then deli = "" Else deli = ", "
        cols = cols & deli & colName: vals = vals & deli & val
    Next

    'SQL文を構築
    Dim table As String: table = "[m_employee]" 'ActiveSheet.Name
    ProcessRowAsSql = _
        "insert into " & table & "(" & cols & ") values(" & vals & ");"
End Function

'カラム名・型に応じたSQL値の編集
Function EditSqlVal(colName As String, colType As String, val As String)
    colName = LCase(colName): colType = LCase(colType)
    Select Case True
        Case val = ""
            val = "null"
        Case InStr(colType, "char") > 0 Or InStr(colType, "text") > 0
            val = "'" & val & "'"
        Case InStr(colType, "date") > 0 Or InStr(colType, "time") > 0
            val = "'" & val & "'"
    End Select
    EditSqlVal = val
End Function

行編集関数：JSON

  • JSONを作成する行編集関数です。
    • 値を編集したい場合、EditJsonVal()の内容を変更してください。
    • フィールド名をケバブケース／スネークケース／パスカルケース／キャメルケース等に変換したい場合は、こちらをご覧ください。
    '行編集関数: JSON
'※先頭・最終行の[]を出力する関係で、生成件数genCountがずれる場合があります。
Function ProcessRowAsJsn(headRows As Range, dataRows As Range, rowIdx As Integer)
    
    Dim line As String, colIdx As Integer
    Dim colName As String, colType As String, val As String, deli As String

    '先頭行の場合、配列を開く
    If rowIdx = 1 Then line = line & "[" & vbCrLf
    
    If dataRows.Cells(rowIdx, 1) <> "" Then
        
        'JSONオブジェクトを生成: { "field1": value1, "field2": "value2", ... }
        line = line & "  {" & vbCrLf
        For colIdx = 1 To dataRows.Columns.Count
            colName = headRows.Cells(1, colIdx)
            colType = headRows.Cells(2, colIdx)
            val = EditJsonVal(colName, colType, dataRows.Cells(rowIdx, colIdx))
            If colIdx = 1 Then deli = "" Else deli = "," & vbCrLf
            line = line & deli & "    """ & colName & """: " & val
        Next
        line = line & vbCrLf & "  }"
        
        '次の行にデータがある場合はデリミタ追加(データ抜け行がない前提)
        If dataRows.Cells(rowIdx + 1, 1) <> "" Then line = line & ","
    End If

    '最終行の場合、配列を閉じる
    If rowIdx = dataRows.Count Then
        If line <> "" Then line = line & vbCrLf '生成データがある場合
        line = line & "]"
    End If
    
    ProcessRowAsJsn = line
End Function

'カラム名・型に応じたJSON値の編集
Function EditJsonVal(colName As String, colType As String, val As String)
    colName = LCase(colName): colType = LCase(colType)
    Select Case True
        Case val = ""
            val = "null"
        Case InStr(colType, "char") > 0 Or InStr(colType, "text") > 0
            val = """" & val & """"
        Case InStr(colType, "date") > 0 Or InStr(colType, "time") > 0
            val = """" & val & """"
    End Select
    EditJsonVal = val
End Function

UTF-8による再保存

  • Shift_JISで保存されたファイルをUTF-8(BOMなし)で保存し直す関数です。
    • Windows環境ではない場合、6行目のエンコーディングを実行環境のものに変更してください。
    • BOMを付けて出力したい場合、15行目(“.Position = 3”)をコメントアウトしてください。（他にも冗長な部分がありますが、動作に影響はないので無視します。）
    'UTF-8で保存し直す
Sub ResaveAsUtf8(filename As String)
    Dim str As String, buf() As Byte
    With CreateObject("ADODB.Stream")
        .Open 'SJISファイルを文字列として読み込み
        .Charset = "Shift-JIS"
        .LoadFromFile filename
        str = .ReadText
        .Close
        .Open 'UTF-8書き込み後、BOMを除いたバイナリとして取得
        .Charset = "UTF-8"
        .WriteText str
        .Position = 0
        .Type = 1 'adTypeBinary
        .Position = 3 '★BOM付与時はコメントアウト
        buf = .Read
        .Close
        .Open '前述のバイナリをファイルに書き込み
        .Write buf
        .SaveToFile filename, 2 'adSaveCreateOverWrite
        .Close
    End With
End Sub