エクセルのVBAでアクティブなシートのデータをCSVファイルに書き込む汎用的な関数を作ってみました。
writeCSVwithSingleQuotation1関数は、’で囲んで、カンマで区切って、セルの生データをCSVファイルに保存するの関数です。
writeCSVwithSingleQuotation2関数は、’で囲んで、カンマで区切って、セルの書籍設定が効いた表示データをCSVファイルに保存するの関数です。
writeCSVwithDoubleQuotation1関数は、”で囲んで、カンマで区切って、セルの生データをCSVファイルに保存するの関数です。
writeCSVwithDoubleQuotation2関数は、”で囲んで、カンマで区切って、セルの書籍設定が効いた表示データをCSVファイルに保存するの関数です。
writeCSVwithNoQuotation1関数は、カンマで区切るだけで、セルの生データをCSVファイルに保存するの関数です。
writeCSVwithNoQuotation2関数は、カンマで区切るだけで、セルの書籍設定が効いた表示データをCSVファイルに保存するの関数です。
writeCSV関数は各関数から呼び出されて、CSVファイルに書き込むメインの処理の関数です。
ファイル名と保存先のパスは各関数で希望するものに変更してください。
なお、保存したいシートをアクティブにして、保存したい表の中のいずれかのセルを選択した状態で、マクロから呼び出してください。
Macでの注意
Macでは、エクセルファイルをOneDriveから、ローカルのMacにコピーしてから使用してください。
また、CSVファイルの名前の前にある¥記号を/(スラッシュ)に変更してみてください。
それでうまく動かない時は報告していただけると助かります。
Option Explicit
Public Sub writeCSVwithSingleQuotation1()
Dim filePath As String
filePath = ThisWorkbook.Path & "\sample01.csv"
writeCSV filePath, "'", True
End Sub
Public Sub writeCSVwithSingleQuotation2()
Dim filePath As String
filePath = ThisWorkbook.Path & "\sample01.csv"
writeCSV filePath, "'", False
End Sub
Public Sub writeCSVwithDoubleQuotation1()
Dim filePath As String
filePath = ThisWorkbook.Path & "\sample01.csv"
writeCSV filePath, """", True
End Sub
Public Sub writeCSVwithDoubleQuotation2()
Dim filePath As String
filePath = ThisWorkbook.Path & "\sample01.csv"
writeCSV filePath, """", False
End Sub
Public Sub writeCSVwithNoQuotation1()
Dim filePath As String
filePath = ThisWorkbook.Path & "\sample01.csv"
writeCSV filePath, "", True
End Sub
Public Sub writeCSVwithNoQuotation2()
Dim filePath As String
filePath = ThisWorkbook.Path & "\sample01.csv"
writeCSV filePath, "", False
End Sub
'メインの処理用関数
Private Sub writeCSV(ByVal fileName As String, ByVal quote As String, ByVal rawData As Boolean)
Dim fileNum As Integer
Dim buf As String
'最初にアクティブだったシート
Dim ws As Worksheet
'データがあると思われるセル範囲
Dim dataRange As Range
Dim rowStart As Integer
Dim rowEnd As Integer
Dim colStart As Integer
Dim colEnd As Integer
Dim strQuote As String
'ワークシートの行番号
Dim i As Integer
Dim j As Integer
If fileName = "" Then
Exit Sub
End If
'最初にアクティブなシートにデータがあるとしてシートを記憶しておく
Set ws = ActiveSheet
'データ範囲を自動認識
Set dataRange = ActiveCell.CurrentRegion
'データ範囲をFORループで処理するために行番号と列番号の範囲を取得しておく
rowStart = dataRange.row
rowEnd = rowStart + dataRange.Rows.Count - 1
colStart = dataRange.Column
colEnd = colStart + dataRange.Columns.Count - 1
'データの間のカンマ等を作っておく
strQuote = quote & "," & quote
'空いているファイル番号を取得
fileNum = FreeFile
'書き込みでファイルを開く
Open fileName For Output As #fileNum
For i = rowStart To rowEnd
'各行の先頭のクォテーションを入れて置く
buf = quote
'CSVファイルに書き込む
For j = colStart To colEnd
'生データを書き込むか、書式設定が効いた表示されているデータで書き込むかで分岐
If rawData = True Then
If quote = """" Then
buf = buf & Replace(ws.Cells(i, j).Value, """", """""")
Else
buf = buf & ws.Cells(i, j).Value
End If
Else
If quote = """" Then
buf = buf & Replace(ws.Cells(i, j).Text, """", """""")
Else
buf = buf & ws.Cells(i, j).Text
End If
End If
'1行の最後のデータでなければデータ間を入れて置く
If j <> colEnd Then
buf = buf & strQuote
End If
Next j
buf = buf & quote
'1行を書き込む
Print #fileNum, buf
Next i
Close #fileNum
'変数の開放
Set dataRange = Nothing
Set ws = Nothing
End Sub
