ExcelをCSV, SQL文, JSONに簡単変換(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を出力する行編集関数を含んでいます。）
  
  簡単変換サンプル.xlsm

  Option Explicit '誤動作防止のためConst HeadRowCount = 2 '★ヘッダ行数Const DataStartA1 = "B5"; '★データ領域(左上)Const DataEndA1 = "";'★データ領域(右下) ※未指定時は自動検出Const OutputFile = ".\output.txt" '★出力先 ※カレントはBookのパスSub Main() GenerateFile Worksheets("Sheet1") '★シート名End SubSub 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 <> "" ThenPrint #1, linegenCount = 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 UsedRangeendA1 = .Cells(.Rows.Count, .Columns.Count).Address(False, False) End With End If Set DetectDataRange = Range(DataStartA1 & ":" & endA1)End Function'行編集関数: CSVFunction 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.CountIf 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 = lineEnd Function

  1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80

  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	要件に近い行編集関数が実行されるよう、不要な行編集関数をコメントアウトしてください。
  39	Windows環境ではShift_JISで保存します。UTF-8で保存したい場合、ResaveAsUtf8関数を実行するようコメントアウトを外してください。
  42	ファイル作成後にコマンドを実行したい場合、Shell関数が実行されるようコメントアウトを外して、希望のコマンドを指定してください。
  57-79	ヘッダ行、データ行の全ての項目を引用符付きで出力する実装になっています。要件に応じて変更してください。

行編集関数：テキスト

• コマンド等の任意のテキストを生成するための行編集関数です。
  • シート上の複数列の値に基づいて内容に基づいて、コマンド等を作成する際に使用する想定です。
  • サンプルで出力しているコマンドテキストはサンプルであり特に意味はありません。
  • 私の業務作業で、Azure上の多数のリソースの作成や変更を行う場合があります。対象リソースや条件をシートに記載し、纏めてPowerShellコマンドを作成する際に使用する想定です。
  簡単変換サンプル.xlsm

  '行編集関数: テキスト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

  1 2 3 4 5 6 7 8 9

  '行編集関数: テキスト 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等の日付・時刻型では引用符付きで値を出力します。
  簡単変換サンプル.xlsm

  '行編集関数: SQLFunction 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") > 0val = "'" & val & "'" Case InStr(colType, "date") > 0 Or InStr(colType, "time") > 0val = "'" & val & "'" End Select EditSqlVal = valEnd Function

  1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35

  '行編集関数: 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()の内容を変更してください。
  • フィールド名をケバブケース／スネークケース／パスカルケース／キャメルケース等に変換したい場合は、こちらをご覧ください。
  簡単変換サンプル.xlsm

  '行編集関数: 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.CountcolName = headRows.Cells(1, colIdx)colType = headRows.Cells(2, colIdx)val = EditJsonVal(colName, colType, dataRows.Cells(rowIdx, colIdx))If colIdx = 1 Then deli = "" Else deli = "," & vbCrLfline = 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 = lineEnd 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") > 0val = """" & val & """" Case InStr(colType, "date") > 0 Or InStr(colType, "time") > 0val = """" & val & """" End Select EditJsonVal = valEnd Function

  1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49

  '行編集関数: 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”)をコメントアウトしてください。（他にも冗長な部分がありますが、動作に影響はないので無視します。）
  簡単変換サンプル.xlsm

  '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 WithEnd Sub

  1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23

  '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