Rangeを渡してCSV出力させる関数です。
(2018/06/15更新)
Option Explicit
'==================================================
' CSV出力関数
'
' ◆引数
' (1)myRange CSV出力範囲
' (2)outputFilename 出力ファイル名プレフィックス
'--------------------------------------------------
'呼び出し側実装例
'Private Sub btn_Click()
' '出力ファイル名セル（基準のセル）
' Const strCell As String = "A4"
' 'CSV出力開始行オフセット（基準のセルの下何行目から開始か）
' Const intOfs As Integer = 4
'
' Dim baseRng As Range
' Set baseRng = Range(strCell).Offset(intOfs, 0)
'
' '(1)自動で範囲を決定(セルに歯抜けがない場合に有効)
' 'Call ExportCSV(Range(baseRng, baseRng.End(xlDown).End(xlToRight)), Range(strCell).Value)
'
' '(2)範囲を手動で指定
' Const row As Integer = 16 ' 行数
' Const column As Integer = 10 ' 列数
' Call ExportCSV(Range(baseRng, baseRng.Offset(row - 1, column - 1)), Range(strCell).Value)
'End Sub
'==================================================
Public Sub ExportCSV(ByVal myRange As Range, ByVal outputFilename As String)
Dim curRow As Range 'ループ時の現在処理行
Dim loopIndex As Integer 'ループインデックス
Dim fso As New FileSystemObject 'ファイルシステムオブジェクト（参照設定：Microsoft Scripting Runtime）
Dim ts As TextStream 'テキストストリーム
'固定値 除外文字列
Const IGNORE As String = "<NULL>"
'固定値 ダブルクォート
Const WQ As String = """"
'固定値 カンマ
Const COMMA As String = ","
'出力ファイル名
Dim prefix As String
If outputFilename = "" Then
prefix = "OUTPUTFILE_"
Else
prefix = outputFilename & "_"
End If
'デスクトップのパス取得
Dim Path As String
Dim WSH As Object
Set WSH = CreateObject("WScript.Shell")
Path = WSH.SpecialFolders("Desktop") & "\"
'ファイル名決定
Dim Filename As String
Filename = prefix & Format(Now, "yyyymmddhhnnss") & ".csv"
'確認メッセージ
Dim res As Integer
res = MsgBox("CSV出力を開始します。" & vbNewLine & "よろしいですか？", vbQuestion + vbYesNo + vbDefaultButton2, "確認")
If res = vbNo Then Exit Sub
'例外処理
On Error GoTo ENDSUB
'ファイルオープン
Set ts = fso.OpenTextFile(Path & Filename, ForWriting, True)
'◇ファイル出力処理開始
'行のループ
For Each curRow In myRange.Rows
'1列目が空白の行はスキップ
If curRow.Columns(1) = "" Then GoTo ENDLOOP
'列のループ
For loopIndex = 1 To myRange.Columns.Count
'除外文字列置換
Dim curCell As String
curCell = curRow.Cells(1, loopIndex)
curCell = Replace(curCell, IGNORE, "")
'ダブルクォート置換
curCell = Replace(curCell, WQ, WQ & WQ)
'セル書き出し
ts.Write IIf(loopIndex > 1, COMMA, "") & WQ & curCell & WQ
Next
'改行
ts.Write vbNewLine
ENDLOOP:
Next
'ファイルクローズ
ts.Close
'終了メッセージ
Call MsgBox("終了しました。" & vbNewLine & Filename, vbOKOnly + vbInformation, "情報")
'サブルーチン終了
Exit Sub
'例外処理
ENDSUB:
Call MsgBox(Err.Number & ":" & Err.Description, vbCritical + vbOKOnly, "エラー")
End
End Sub
