【ExcelVBA】指定したシートをテキスト形式(カンマ区切りCSV、タブ区切りTSV)に変換して別名保存する

1.サンプル

Excelブック「D:\Blog\ExcelVBA\FC_SheetOutfile\都道府県リスト.xlsx」が開いている状態とします。

このワークシート「都道府県」をテキスト化します。

2.実行例

Shift_JISのカンマ区切りCSVに変換

以下は、文字コードShift_JISのカンマ区切りファイルに変換する実行例です。

Sub main()
    
    '対象シートのオブジェクト化
    Dim wb As Workbook: Set wb = Workbooks("都道府県リスト.xlsx")
    Dim ws As Worksheet: Set ws = wb.Worksheets("都道府県")
    
    'テキストファイルに変換
    FC_SheetOutfile sheet:=ws, fileName:=wb.Path & "\" & "都道府県.csv"

End Sub

引数encodeを省略、または、ブランク「encode:=""」を指定した場合はShift_JISになります。
また、引数fileNameに拡張子.tsvか.txtを指定すればタブ区切りになります。

以下のように、文字コードShift_JISのカンマ区切りファイルに変換されました。

UTF-8のタブ区切りTSVに変換

以下は、文字コードUTF-8のタブ区切りファイルに変換する実行例です。

Sub main()
    
    '対象シートのオブジェクト化
    Dim wb As Workbook: Set wb = Workbooks("都道府県リスト.xlsx")
    Dim ws As Worksheet: Set ws = wb.Worksheets("都道府県")
    
    'テキストファイルに変換
    FC_SheetOutfile sheet:=ws, fileName:=wb.Path & "\" & "都道府県.txt", encode:="utf-8"

End Sub

引数encodeを省略、または、ブランク「encode:=""」を指定した場合はShift_JISになるので、それ以外を指定すればUTF-8になります。
ゆえに、encode:="utf-8"、encode:="utf8"、encode:="あああ"、のいずれを指定してもUTF-8になります。

以下のように、文字コードUTF-8のタブ区切りファイルに変換されました。

UTF-8、BOMなしのタブ区切りTSVに変換

以下は、文字コードUTF-8でBOMなしのタブ区切りファイルに変換する実行例です。

Sub main()
    
    '対象シートのオブジェクト化
    Dim wb As Workbook: Set wb = Workbooks("都道府県リスト.xlsx")
    Dim ws As Worksheet: Set ws = wb.Worksheets("都道府県")
    
    'テキストファイルに変換
    FC_SheetOutfile sheet:=ws, fileName:=wb.Path & "\" & "都道府県_BOMなし.txt", encode:="utf-8", bom:=False

End Sub

引数BOMにFalseを指定すればBOMなしになります。

パッと見た感じではわかりにくいのですが、BOMなしに変換されています。

3.コード

以下はFunctionモジュールのプログラムになります。
右上のコピーボタンを押せば、プログラム全体をコピーできます。

Function FC_SheetOutfile(sheet As Worksheet, fileName As String, _
                        Optional encode As String = "Shift_JIS", Optional bom As Boolean = True, _
                        Optional closeBook As Boolean = False)
'指定したシートをテキスト形式(カンマ区切りCSV、タブ区切りTSV)に変換して別名保存する
'sheet      :対象シートオブジェクトを指定する
'fileName   :保存するファイル名をフルパスで指定する
'encode     :保存する文字コードを指定する（既定値=Shift_JIS、ブランクはShift_JISとして扱い、それ以外はUTF-8として扱う）
'bom        :UTF-8で保存する場合、BOMを削除する場合はFalseを指定する（既定値=True）
'closeBook  :保存後に、対象シートを含むワークブックを閉じる場合はTrueを指定する（既定値=False）

    Dim str As String
    Dim buf As Variant
    Dim orgDisplayAlerts As Boolean: orgDisplayAlerts = Application.DisplayAlerts
    Dim i&, j&
    Const startRow As Long = 1
    Const startCol As Long = 1
    
    'ADODBの設定
    Dim ado1 As Object: Set ado1 = CreateObject("ADODB.Stream")
    ado1.Type = 2      'テキストデータ
    
    '文字コード
    If encode = "" Or InStr(1, encode, "jis", vbTextCompare) > 0 Then
        ado1.Charset = "Shift_JIS"
    Else
        ado1.Charset = "UTF-8"
    End If
    
    ado1.LineSeparator = -1 '改行復帰行送り（デフォルト）
    ado1.Open
    
    '最終行までループ
    For i = startRow To sheet.UsedRange.Rows(sheet.UsedRange.Rows.Count).Row
        str = ""
        '最終列までループ
        For j = startCol To sheet.UsedRange.Columns(sheet.UsedRange.Columns.Count).Column
            '先頭列以外
            If j > startCol Then
            
                'タブ区切りの拡張子は「.txt」、「.tsv」とする
                If InStr(1, fileName, ".txt", vbTextCompare) > 0 Or InStr(1, fileName, ".tsv", vbTextCompare) > 0 Then
                    If IsError(sheet.Cells(i, j)) = False Then
                        If InStr(sheet.Cells(i, j), ",") > 0 Or InStr(sheet.Cells(i, j), """") > 0 Then
                            str = str & vbTab & """"
                        Else
                            str = str & vbTab
                        End If
                    Else
                        str = str & vbTab
                    End If
                ElseIf InStr(1, fileName, ".csv", vbTextCompare) > 0 Then
                    If IsError(sheet.Cells(i, j)) = False Then
                        If InStr(sheet.Cells(i, j), ",") > 0 Or InStr(sheet.Cells(i, j), """") > 0 Then
                            str = str & ","""
                        Else
                            str = str & ","
                        End If
                    Else
                        str = str & ","
                    End If
                End If
            '1列目
            Else
                If IsError(sheet.Cells(i, j)) = False Then
                    If InStr(sheet.Cells(i, j), ",") > 0 Or InStr(sheet.Cells(i, j), """") > 0 Then
                        str = str & """"
                    End If
                End If
            End If
            buf = sheet.Cells(i, j).Text
            If InStr(buf, """") > 0 Then buf = Replace(buf, """", """""")
            str = str & buf
            If IsError(sheet.Cells(i, j)) = False Then
                If InStr(sheet.Cells(i, j), ",") > 0 Or InStr(sheet.Cells(i, j), """") > 0 Then
                    str = str & """"
                End If
            End If
        Next
        ado1.WriteText str, 1 '文字を改行付きで書き込む
    Next
    
    '対象シートを含むワークブックを閉じる
    If closeBook = True Then
        Application.DisplayAlerts = False
        sheet.Parent.Close
        Application.DisplayAlerts = orgDisplayAlerts
    End If
    
    'Shift_JISまたはBOMありの場合
    If encode = "" Or InStr(1, encode, "jis", vbTextCompare) > 0 Or bom = True Then
        ado1.SaveToFile fileName, 2 '指定したファイルが既に存在する場合、上書きする
        Exit Function
    End If
    
    'BOMを削る前処理
    ado1.Position = 0 'ファイル先頭にセット
    ado1.Type = 1 'バイナリに変更
    ado1.Position = 3 'BOMの3バイト分スキップ
    
    'BOMを削った分をコピー
    Dim ado2 As Object: Set ado2 = CreateObject("ADODB.Stream")
    ado2.Type = 1   'バイナリデータ
    ado2.Open
    ado1.CopyTo ado2
    
    '名前を付けて保存
    ado2.SaveToFile fileName, 2 '指定したファイルが既に存在する場合、上書きする
    
    'クローズ処理
    ado1.Close
    ado2.Close
    
End Function