【Excel】ExcelからCSV書きだす方法

Option Explicit

' CSV形式テキストファイル書き出すサンプル
Sub WRITE_CSVFile()
    Const cnsTITLE = "CSVテキストファイル出力処理"
    Const cnsFILTER = "CSVファイル (*.csv;*.dat),*.csv;*.dat"
    Dim xlAPP As Application        ' Applicationオブジェクト
    Dim intFF As Integer            ' FreeFile値
    Dim strFILENAME As String       ' OPENするファイル名(フルパス)
    Dim X(1 To 5) As Variant        ' 書き出すレコード内容
    Dim GYO As Long                 ' 収容するセルの行
    Dim GYOMAX As Long              ' データが収容された最終行
    Dim lngREC As Long              ' レコード件数カウンタ
    Dim COL As Long                 ' カラム(Work)

    ' Applicationオブジェクト取得
    Set xlAPP = Application
    ' 「名前を付けて保存」のフォームでファイル名の指定を受ける
    xlAPP.StatusBar = "出力するファイル名を指定して下さい。"
    strFILENAME = xlAPP.GetSaveAsFilename(InitialFilename:="SAMPLE.csv", _
        FileFilter:=cnsFILTER, Title:=cnsTITLE)
    ' キャンセルされた場合は以降の処理は行なわない
    If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub

    ' 収容最終行の判定(Excel認知の最終行から上に向かってデータがある行を探す)
    GYOMAX = Cells.SpecialCells(xlCellTypeLastCell).Row
    Do While Cells(GYOMAX, 1).Value = ""
        GYOMAX = GYOMAX - 1
    Loop
    If GYOMAX < 2 Then
        xlAPP.StatusBar = False
        MsgBox "テキストをA～E列2行目から入力してから起動して下さい。",, cnsTITLE
        Exit Sub
    End If

    ' FreeFile値の取得(以降この値で入出力する)
    intFF = FreeFile
    ' 指定ファイルをOPEN(出力モード)
    Open strFILENAME For Output As #intFF
    ' 2行目から開始
    GYO = 2
    ' 最終行まで繰り返す
    Do Until GYO > GYOMAX
        Erase X         ' 初期化                                     ' ①
        ' A～E列内容をレコードにセット(先頭は2行目)
        For COL = 1 To 5
            X(COL) = FP_CutInjusticeChar(Cells(GYO, COL).Value)      ' ②
        Next COL
        ' レコード件数カウンタの加算
        lngREC = lngREC + 1
        xlAPP.StatusBar = "出力中です．．．．(" & lngREC & "レコード目)"
        ' レコードを出力
        Write #intFF, X(1), X(2), X(3), X(4), X(5)                   ' ③
        ' 行を加算
        GYO = GYO + 1
    Loop
    ' 指定ファイルをCLOSE
    Close #intFF
    xlAPP.StatusBar = False
    ' 終了の表示
    MsgBox "ファイル出力が完了しました。" & vbCr & _
        "レコード件数=" & lngREC & "件", vbInformation, cnsTITLE
End Sub

' CSVテキスト項目に出力できない文字を除去する
Private Function FP_CutInjusticeChar(vntInText As Variant) As Variant
    Dim strInText2 As String
    Dim POS As Long
    Dim strChar As String
    Dim strOutText As String

    FP_CutInjusticeChar = Empty
    ' 一旦、文字列に変換する
    strInText2 = Trim$(CStr(vntInText))
    ' ブランクの場合は処理なし
    If strInText2 = "" Then Exit Function

    ' 文字列の桁数分繰り返す
    strOutText = ""
    For POS = 1 To Len(strInText2)
        ' 1文字を取り出す
        strChar = Mid(strInText2, POS, 1)
        ' ダブルクォーテーションとCRコードをOMIT
        If ((strChar <> vbCr) And (strChar <> """")) Then
            strOutText = strOutText & strChar
        End If
    Next POS
    ' 元の値が数値の場合はDouble型とする
    If IsNumeric(vntInText) = True Then
        FP_CutInjusticeChar = CDbl(strOutText)
    Else
        FP_CutInjusticeChar = strOutText
    End If
End Function