VBAで複数のシートのデータをCSVファイルで出力する

要約

参考

• CSVの出力（書き出し）方法

出力する際の文字コードに関する注意点

VBAでファイルを出力する場合は、基本的にSHIFT-JISになる。
UTF-8で出力したい場合は一工夫いる。

流れ

• 保存形式の指定。
• すべてのシート名を配列名に格納する。
• 1枚目のシートを選択する。
• セル(1,1)→セル(1,2)→…→セル(2,1)→…→セル(m,n)の順にファイルに書き込んでいく。
• 次のシートを選択する。
• 上の二つを繰り返す。

完成したコード

Shift-JISで出力する場合

Sub outputCSV_shiftjis()
    Dim dtDate As String
    Dim fileSaveName As Variant

    Dim k As Integer
    Dim mySheetCnt As Integer
    Dim mySheetName() As String

    Dim iCnt As Integer
    Dim jCnt As Integer
    Dim maxRow As Integer
    Dim maxCol As Integer
    Dim val As String

    '''保存ダイアログを開く
    dtDate = Format(Now, "yyyymmdd")
    fileSaveName = Application.GetSaveAsFilename( _
                    InitialFileName:=dtDate & ".csv", _
                    FileFilter:="CSVファイル(*.csv),*.csv", _
                    FilterIndex:=1, _
                    Title:="保存ファイルの指定")
    If fileSaveName = False Then Exit Sub


    '''各シート名を配列に格納する
    mySheetCnt = ThisWorkbook.Sheets.Count
    ReDim mySheetName(1 To mySheetCnt)

    For k = 1 To mySheetCnt
        mySheetName(k) = Sheets(k).Name
    Next k


    '''シートを選択してファイルに一行ずつ書き出す
    'ファイルを開く
    Open fileSaveName For Output As #1

    'シート毎に実行
    For k = 1 To mySheetCnt
        Worksheets(mySheetName(k)).Select
        ' 最終行
        maxRow = ActiveSheet.Range("A1").End(xlDown).Row
        ' 最終列
        maxCol = ActiveSheet.Range("A1").End(xlDown).Col

        '行ごとに実行
        For iCnt = 1 To maxRow
            '列ごとに実行
            For jCnt = 1 To maxCol
                val = Cells(iCnt, jCnt)
                if (jCnt < maxCol) Print #1, val & ",";
                if (jCnt = maxCol) Print #1, val
            Next jCnt
        Next iCnt
    Next k

    'ファイルを閉じる
    Close #1
End Sub

UTF-8の場合

Sub outputCSV_utf8()
    Dim dtDate As String
    Dim fileSaveName As Variant

    Dim k As Integer
    Dim mySheetCnt As Integer
    Dim mySheetName() As String

    Dim iCnt As Integer
    Dim jCnt As Integer
    Dim maxRow As Integer
    Dim maxCol As Integer
    Dim val As String

    '''UTF8で保存するための準備
    Dim output As ADODB.Stream
    Set output = New ADODB.Stream


    '''保存ダイアログを開く
    dtDate = Format(Now, "yyyymmdd")
    fileSaveName = Application.GetSaveAsFilename( _
                    InitialFileName:=dtDate & ".csv", _
                    FileFilter:="CSVファイル(*.csv),*.csv", _
                    FilterIndex:=1, _
                    Title:="保存ファイルの指定")
    If fileSaveName = False Then Exit Sub


    '''各シート名を配列に格納する
    mySheetCnt = ThisWorkbook.Sheets.Count
    ReDim mySheetName(1 To mySheetCnt)

    For k = 1 To mySheetCnt
        mySheetName(k) = Sheets(k).Name
    Next k


    '''UTF8で書き込む
    With output
        .Type = adTypeText
        .Charset = "UTF-8"
        .Open

        ''シートを選択してファイルに一行ずつ書き出す
        For k = 1 To mySheetCnt
            Worksheets(mySheetName(k)).Select
            ' 最終行
            maxRow = ActiveSheet.Range("A1").End(xlDown).Row
            ' 最終列
            maxCol = ActiveSheet.Range("A1").End(xlDown).Col

            '行ごとに実行
            For iCnt = 1 To maxRow
                '列ごとに実行
                For jCnt = 1 To maxCol
                    val = Cells(iCnt, jCnt)

                    if (jCnt < maxCol) .WriteText val & ","
                    if (jCnt = maxCol) .WriteText val, adWriteLine
                    End If
                Next jCnt
            Next iCnt
        Next k

        'ファイルを保存して閉じる
        .SaveToFile fileSaveName, adSaveCreateOverWrite
        .Close
    End With
End Sub

手順

保存形式の指定

【参考】

GetSaveAsFilename(InitialFilename, FileFilter, FilterIndex, Title, ButtonText)

[名前を付けて保存] ダイアログ ボックスを表示する。

例

varFile = Application.GetSaveAsFilename(InitialFileName:=dtDate & ".csv", _
                                        FileFilter:="CSVファイル(*.csv),*.csv", _
                                        FilterIndex:=1, _
                                        Title:="保存ファイルの指定")

ファイル名に現在時刻を追加する(yyyymmdd形式)

Dim dtDate As String
dtDate = Format(Now, "yyyymmdd")

すべてのシート名を配列に格納する

【参考】

    Dim k As Long
    Dim mySheetCnt As Long
    Dim mySheetName() As String

    mySheetCnt = ThisWorkbook.Sheets.Count
    ReDim mySheetName(1 To mySheetCnt)

    For k = 1 To mySheetCnt
        mySheetName(k) = Sheets(k).Name
    Next k

mySheetNameを動的配列として宣言して、mySheetCntにシートの枚数を代入。その後、シートの数だけ配列の要素数を確保する。

シートを選択して、最後の行まで読み取る

シートの選択

Worksheets(mySheetName(k)).Select

ファイルを開く＆閉じる

【参考】

ファイルに書き込む(SHIFT-JIS)

【参考】

Print #filenumber, [outputlist]

一行ずつ書き込まれていく。デフォルトの改行コードはCRLF。
末尾に；をつけると改行されない。

ファイルに書き込む(UTF-8)

【参考】