ExcelファイルをCSV出力する

• OracleにデータをローディングするうえでCSVに変換する必要があったので書いた
• Excelで「名前を付けて保存」でCSVで保存することはできるけど、書式設定されたセルは、生のデータではなく書式に合わせて表示されている形式のままCSVで保存されるため、書式をクリアする必要があった
• ので、VBAでビャッとCSV化する処理を作成する

* シンタクスハイライトはvbaとかvbとかvbsとか、MS系は非対応なんですね↓
* vba苦手なので、お作法とかあったら教えてほしい。。

vba

Sub メイン処理()

    ' 定数定義
    Const File_Full_Path_Cell As String = "D2" ' エクセルのパスを入力したセル
    Const Export_File_Path_Cell As String = "D4"   ' 出力先パスを入力したセル
    Const Data_File_Name_Cell As String = "D5" ' 出力ファイル名を入力したセル

    ' 変数定義
    Dim Return_Code As Integer       ' 戻り値
    Dim File_Full_Path As String ' パス
    Dim Export_File_Path As String   ' 出力先パス
    Dim Data_File_Name As String ' ファイル名

    ' このブックのオブジェクトを生成
    Dim objSH As Worksheet
    Set objSH = ThisWorkbook.ActiveSheet

    ' このブックのセル情報を取得
    File_Full_Path = objSH.Range(File_Full_Path_Cell)
    Export_File_Path = objSH.Range(Export_File_Path_Cell)
    Data_File_Name = objSH.Range(Data_File_Name_Cell)

    '''''''''''''''''''''''
    ' 処理開始
    '''''''''''''''''''''''

    ' ファイルのオープン
    MsgBox File_Full_Path_Cell & ":" & vbCrLf & File_Full_Path & vbCrLf & "を処理します。"
    Return_Code = ファイルオープン(File_Full_Path)

    ' エクセルデータの書式変換
    If Return_Code = 0 Then
        Return_Code = 書式変更()
    End If

    ' CSV形式にエクスポート
    If Return_Code = 0 Then
        Return_Code = CSVエクスポート(Export_File_Path & "\" & Data_File_Name)
    End If


    '''''''''''''''''''''''
    ' 終了処理
    '''''''''''''''''''''''

    If Return_Code = 0 Then
        MsgBox "処理が正常終了しました。"
    Else
        MsgBox "処理を終了します。処理中にエラーまたは取り消し処理が発生しています。"
    End If

End Sub





Function 書式変更() As Integer
'
' Excel上で%表示されている列を、ただの値として表示するようにする
'

    ''''''''''''
    ' 定数定義
    ''''''''''''
    Const Market_Size As String = "F"         ' マーケットサイズ列
    Const Market_Share As String = "G"        ' マーケットシェア列

    ' 書式変換処理
    Columns(Market_Size & ":" & Market_Size).Select
    Selection.NumberFormatLocal = "G/標準"

    Columns(Market_Share & ":" & Market_Share).Select
    Selection.NumberFormatLocal = "G/標準"


    書式変更 = 0

End Function


Function ファイルオープン(Path As String) As String
'
' 指定したパスにあるファイルをオープン
'

    ' 変数定義
    Dim Return_Code As Integer
    Dim pos As Long
    Dim Path_Name As String
    Dim File_Name As String
    Dim Work_Book As Workbook


    ' 変数初期化
    Return_Code = 0

    ' ファイル名取得
    pos = InStrRev(Path, "\")
    Path_Name = Left(Path, pos)
    File_Name = Mid(Path, pos + 1)


    ' ファイルが既に開いているかチェック
    For Each Work_Book In Workbooks
        If Work_Book.Name = File_Name Then
            MsgBox File_Name & vbCrLf & "はすでに開いています。"
            Return_Code = 9
        End If
    Next Work_Book

    ' ファイル存在チェック
    If Dir(Path) = "" Then
        MsgBox Path & vbCrLf & "が存在しません。"
        Return_Code = 9
    End If

    ' ファイルオープン
    If Return_Code = 0 Then
        Workbooks.Open Path
    End If

    ' リターン
    ファイルオープン = Return_Code


End Function


Function CSVエクスポート(File_Name As String) As Integer
'
' 指定したパスにあるファイルをCSV形式で保存
'

    ' 定数定義
    Const Extension As String = ".csv" ' 拡張子

    ' 変数定義
    Dim Return_Code As Integer
    Dim File_Name_With_Extension As String ' 拡張子込のファイルフルパス

    ' 変数初期化
    Return_Code = 0

    ' 出力ファイル名を生成
    File_Name_With_Extension = File_Name & Extension

    ' 下記保存時に、上書き確認メッセージで「いいえ」を選択した際にアベンドしないようにする
    On Error Resume Next

    ' ファイル作成
    Sheets(1).Select
    ActiveWorkbook.SaveAs FileName:=File_Name_With_Extension, FileFormat:=xlCSV

    ' 上書き確認メッセージで「いいえ」を選択した
    If Err.Number > 0 Then
        MsgBox "保存されませんでした"

        ' 開いたエクセルを閉じる
        Application.DisplayAlerts = False
        ActiveWindow.Close
        Application.DisplayAlerts = True

        Return_Code = 9
    End If

    ' エラーハンドリングの設定を初期化（エラー時はアベンドするように戻す）
    On Error GoTo 0

    If Return_Code = 0 Then
        ' ファイルは閉じてしまう
        Application.DisplayAlerts = False
        ActiveWindow.Close
        Application.DisplayAlerts = True
    End If

    CSVエクスポート = Return_Code

End Function