Excel VBAで独自形式のCSVファイルを作成

Excel/Word

1 概要
2 サンプルの紹介
3 サンプルコード

概要

ExcelはRFC4180に準拠したCSV出力が可能ですが、逆にRFC4180に準拠しない独自形式のCSV出力はできません。
そのため、ここではExcel VBAを使って独自のCSVファイルを出力するサンプルを紹介します。
サンプルの内容を少々変更すれば、タブ区切りファイル(TSV)やSQLインサート文の作成等にも対応できます。このように応用する前提のサンプルであるため、可能な限りシンプルにしています。
動作確認した環境は次の通りです。
OS Windows 10(64ビット)
Office Microsoft Office Professional Plus 2019
(Microsoft® Excel® 2019 MSO (16.0.14228.20216) 32 ビット )

OS	Windows 10(64ビット)
Office	Microsoft Office Professional Plus 2019 (Microsoft® Excel® 2019 MSO (16.0.14228.20216) 32 ビット )

サンプルの紹介

※ここで説明する仕様はサンプル用であり、VBAコードを修正すれば簡単に変更できます。

シートに定義した行・列データをCSV形式でファイル(UTF-8)に出力します。（１シート１ファイル）
先頭のサマリシートにある「一括ファイル出力」ボタンを押すことで、各シートからのファイル出力を一括で行えます。
（先頭が数字３桁で始まるシートが対象となります。）
各シートの「ファイル出力」ボタンを押すことで、シート個別にファイル出力を行えます。
ファイルの出力先は、Excelファイルがあるフォルダ直下のoutputフォルダです。
ファイル名は「シート名＋”.csv”」としています。
サンプルでは、カンマ、ダブルクォーテーション、改行等の特殊な文字が含まれていても、そのままファイルに出力しています。要件に応じた内容を出力できるようサンプルを修正してください。

リンク

サンプルコード

このサンプルでは、UTF8形式でファイル保存するためにADO関連ライブラリを使用しています。
参照設定で「”Microsoft ActiveX Data Objects X.X Library”」を追加してください。
データの読み取りを開始する行・列位置、出力フォルダ等を変更したい場合は「★」印を参考にしてください。
サンプルの完全なコード(Excelのxlsmファイル)は、こちらからダウンロードできます。

Option Explicit'★シートでの読み取り開始列(A始まり)Const StartCol As String = "B"'★シートでの読み取り開始行(1始まり)Const StartRowIndex As Integer = 2'★列区切りと拡張子'Const ExtName As String = ".tsv"'Const Deli As String = vbTabConst ExtName As String = ".csv"Const Deli As String = ","'出力先フォルダ(事前作成が必要)Const BaseFolder As String = ".\output"'一部省略......................'対象シートの領域をファイルに出力Sub OutputCsvFile(sheetName As String, filename As String) Dim ws As Worksheet: Set ws = Worksheets(sheetName) Dim i As Integer, j As Integer  'シート上の使用領域の最終行列を取得(見た目と一致しない場合あり) Dim maxRowIndex As Integer, maxColIndex As Integer maxRowIndex = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).row maxColIndex = ws.UsedRange.Columns(ws.UsedRange.Columns.Count).Column '開始列・終了列インデックスを決定 Dim startColIndex As Integer startColIndex = Asc(StartCol) - Asc("A") + 1 Dim endColIndex As Integer: endColIndex = startColIndex For i = startColIndex To maxColIndex  If ws.Cells(StartRowIndex, i).value = "" Then Exit For  endColIndex = i Next '各行の列値を抽出してレコードデータを生成 Dim content As String'全体データ(ファイル内容) Dim record As String '行データ Dim value As String content = "" For i = StartRowIndex To maxRowIndex  record = ""  For j = startColIndex To endColIndex'★出力値を加工する場合はこの辺を修正してください。'空行や未使用領域をスキップvalue = ws.Cells(i, j).valueIf j = 0 And value = "" Then GoTo Skip'行データに値を追加If record <> "" Then record = record & Delirecord = record & value  Next '生成行を追加(最終行に改行を含めない)  If content <> "" Then content = content & vbCrLf  content = content & recordSkip: Next  '生成したCSVデータをファイルに保存 SaveAsUtf8 filename, contentEnd Sub'コンテンツをUTF-8形式のファイルに上書き保存する。'(ファイルパス上のフォルダは存在する前提)Public Sub SaveAsUtf8(filename As String, contents As String)  If contents = "" Then  MsgBox "空ファイルの出力はスキップ: " & filename  Exit Sub End If  '次の参照設定が必要 '"Microsoft ActiveX Data Objects 6.1 Library" Dim oStream As New ADODB.Stream  With oStream'ファイルオープン  .Charset = "UTF-8"  .LineSeparator = adCRLF  .Type = adTypeText  .Open'データを出力  .WriteText contents'ストリームをバイト列としてbufに退避  Dim buf() As Byte  .Position = 0  .Type = adTypeBinary  .Position = 3 'BOM(3バイト)を読み飛ばし(空ファイルは想定外)  buf = .Read  .Close'バイト列をファイルに出力  .Open  .Position = 0  .Type = adTypeBinary  .Write buf  .SaveToFile filename, adSaveCreateOverWrite .Close End With  Set oStream = NothingEnd Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

Option Explicit

'★シートでの読み取り開始列(A始まり)

Const StartCol As String = "B"

'★シートでの読み取り開始行(1始まり)

Const StartRowIndex As Integer = 2

'★列区切りと拡張子

'Const ExtName As String = ".tsv"

'Const Deli As String = vbTab

Const ExtName As String = ".csv"

Const Deli As String = ","

'出力先フォルダ(事前作成が必要)

Const BaseFolder As String = ".\output"

'一部省略......................

'対象シートの領域をファイルに出力

Sub OutputCsvFile(sheetName As String, filename As String)

Dim ws As Worksheet: Set ws = Worksheets(sheetName)

Dim i As Integer, j As Integer

'シート上の使用領域の最終行列を取得(見た目と一致しない場合あり)

Dim maxRowIndex As Integer, maxColIndex As Integer

maxRowIndex = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).row

maxColIndex = ws.UsedRange.Columns(ws.UsedRange.Columns.Count).Column

'開始列・終了列インデックスを決定

Dim startColIndex As Integer

startColIndex = Asc(StartCol) - Asc("A") + 1

Dim endColIndex As Integer: endColIndex = startColIndex

For i = startColIndex To maxColIndex

If ws.Cells(StartRowIndex, i).value = "" Then Exit For

endColIndex = i

'各行の列値を抽出してレコードデータを生成

Dim content As String '全体データ(ファイル内容)

Dim record As String '行データ

Dim value As String

content = ""

For i = StartRowIndex To maxRowIndex

record = ""

For j = startColIndex To endColIndex

'★出力値を加工する場合はこの辺を修正してください。

'空行や未使用領域をスキップ

value = ws.Cells(i, j).value

If j = 0 And value = "" Then GoTo Skip

'行データに値を追加

If record <> "" Then record = record & Deli

record = record & value

'生成行を追加(最終行に改行を含めない)

If content <> "" Then content = content & vbCrLf

content = content & record

Skip:

'生成したCSVデータをファイルに保存

SaveAsUtf8 filename, content

End Sub

'コンテンツをUTF-8形式のファイルに上書き保存する。

'(ファイルパス上のフォルダは存在する前提)

Public Sub SaveAsUtf8(filename As String, contents As String)

If contents = "" Then

MsgBox "空ファイルの出力はスキップ: " & filename

Exit Sub

End If

'次の参照設定が必要

'"Microsoft ActiveX Data Objects 6.1 Library"

Dim oStream As New ADODB.Stream

With oStream

'ファイルオープン

.Charset = "UTF-8"

.LineSeparator = adCRLF

.Type = adTypeText

.Open

'データを出力

.WriteText contents

'ストリームをバイト列としてbufに退避

Dim buf() As Byte

.Position = 0

.Type = adTypeBinary

.Position = 3 'BOM(3バイト)を読み飛ばし(空ファイルは想定外)

buf = .Read

.Close

'バイト列をファイルに出力

.Open

.Position = 0

.Type = adTypeBinary

.Write buf

.SaveToFile filename, adSaveCreateOverWrite

.Close

End With

Set oStream = Nothing

End Sub