現在のExcelワークシートを離れる必要がなく、VBAによってワークシートをCSVファイルのマクロとしてエクスポートする

ワークシートをCSVファイルとして保存するマクロを作成する場合、多くの問題があります。 ほとんどのチュートリアルでは、SaveAsを推奨しています。これは、基本的に次のコードを使用します。

Sub SaveAsCSV()
   ActiveWorkbook.SaveAs FileFormat:=clCSV, CreateBackup:=False
End Sub

これは良い答えですが、名前を付けて保存するのではなく、CSVをエクスポートしたいのです。 SaveAsを実行すると、2つの問題があります。

• 現在のファイルはCSVファイルになります。 元の.xlsmファイルを引き続き使用したいのですが、現在のワークシートの内容を同じ名前のCSVファイルをエクスポートします。
• CSVファイルを上書きするかどうかを尋ねるダイアログボックスが表示されます。

現在のワークシートのみをファイルとしてエクスポートし、元のファイルで使用し続けますか？

まず、次のコードを作成します。

Option Explicit

Public Sub ExportWorksheetAndSaveAsCSV()

Dim wbkExport As Workbook
Dim shtToExport As Worksheet

Set shtToExport = ThisWorkbook.Worksheets("Sheet1")     'Sheet to export as CSV
Set wbkExport = Application.Workbooks.Add
shtToExport.Copy Before:=wbkExport.Worksheets(wbkExport.Worksheets.Count)
Application.DisplayAlerts = False                       'Possibly overwrite without asking
wbkExport.SaveAs Filename:="C:\tmp\test.csv", FileFormat:=xlCSV
Application.DisplayAlerts = True
wbkExport.Close SaveChanges:=False

End Sub

これは要望をほぼ達成しましたが、コードが実行された後もまだいくつかの問題があります。

• “Sheet1″という名前のワークシートのみをエクスポートします。
• 常に同じ一時ファイルにエクスポートして上書きします。
• 区切りは無視されます。

これらの問題を解決し、すべての要件を満たすために、コードを訂正しました。読みやすくするために片づけました。

Option Explicit
Sub ExportAsCSV()

    Dim MyFileName As String
    Dim CurrentWB As Workbook, TempWB As Workbook

    Set CurrentWB = ActiveWorkbook
    ActiveWorkbook.ActiveSheet.UsedRange.Copy

    Set TempWB = Application.Workbooks.Add(1)
    With TempWB.Sheets(1).Range("A1")
      .PasteSpecial xlPasteValues
      .PasteSpecial xlPasteFormats
    End With        

    Dim Change below to"- 4"  to become compatible with .xls files
    MyFileName = CurrentWB.Path &"" & Left(CurrentWB.Name, Len(CurrentWB.Name) - 5) &".csv"

    Application.DisplayAlerts = False
    TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
    TempWB.Close SaveChanges:=False
    Application.DisplayAlerts = True
End Sub

たぶん、読者の皆さんは上記のコードのいくつかの小さな問題を発見しました。

• .CloseとDisplayAlerts=Trueをfinallyに含める必要がありますが、VBAでそれを実行する方法がわかりません。
• 現在のファイル名に4文字（.xlsmなど）が含まれている場合にのみ実行できます。 .xlsExcelファイルでは使用できません。 3文字のファイル拡張子の場合、MyFileNameを設定するときに-5を-4に変更する必要があります。
• 副作用として、クリップボードの内容は現在のワークシートの内容に置き換えられます。

出力（区切りまたは小数点）のカスタマイズが必要な場合、またはデータ集合が大きい（65k行を超える）場合は、次のコードを編集しました。

Option Explicit

Sub rng2csv(rng As Range, fileName As String, Optional sep As String =";", Optional decimalSign As String)
'export range data to a CSV file, allowing to chose the separator and decimal symbol
'can export using rng number formatting!
    Dim f As Integer, i As Long, c As Long, r
    Dim ar, rowAr, sOut As String
    Dim replaceDecimal As Boolean, oldDec As String

    Dim a As Application:   Set a = Application

    ar = rng
    f = FreeFile()
    Open fileName For Output As #f

    oldDec = Format(0,".")     'current client's decimal symbol
    replaceDecimal = (decimalSign <>"") And (decimalSign <> oldDec)

    For Each r In rng.Rows
        rowAr = a.Transpose(a.Transpose(r.Value))
        If replaceDecimal Then
            For c = 1 To UBound(rowAr)
                'use isnumber() to avoid cells with numbers formatted as strings
                If a.IsNumber(rowAr(c)) Then
                    'uncomment the next 3 lines to export numbers using source number formatting
'                    If r.cells(1, c).NumberFormat <>"General" Then
'                        rowAr(c) = Format$(rowAr(c), r.cells(1, c).NumberFormat)
'                    End If
                    rowAr(c) = Replace(rowAr(c), oldDec, decimalSign, 1, 1)
                End If
            Next c
        End If
        sOut = Join(rowAr, sep)
        Print #f, sOut
    Next r
    Close #f

End Sub

Sub export()
    Debug.Print Now,"Start export"
    rng2csv shOutput.Range("a1").CurrentRegion, RemoveExt(ThisWorkbook.FullName) &".csv",";","."
    Debug.Print Now,"Export done"
End Sub

xlPasteFormatsとvalueを追加して、日付が日付として使用されるようにすることで、わずかに改善することもできます。ほとんどの場合、CSV形式で銀行の明細書を保存するため、日付が必要です。

Sub ExportAsCSV()

    Dim MyFileName As String
    Dim CurrentWB As Workbook, TempWB As Workbook

    Set CurrentWB = ActiveWorkbook
    ActiveWorkbook.ActiveSheet.UsedRange.Copy

    Set TempWB = Application.Workbooks.Add(1)
    With TempWB.Sheets(1).Range("A1")
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
    End With

    'Dim Change below to"- 4"  to become compatible with .xls files
    MyFileName = CurrentWB.Path &"" & Left(CurrentWB.Name, Len(CurrentWB.Name) - 5) &".csv"

    Application.DisplayAlerts = False
    TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
    TempWB.Close SaveChanges:=False
    Application.DisplayAlerts = True
End Sub

次には他のバージョンです。

• セル内で明示的に”，”を検索します。
• また、ワークシート内のすべての内容を取得するため、UsedRangeを使用します。
• ワークシートのセルでループするよりは高速であるため、ループには配列を使用します。
• FSOルーチンを使用していませんが、一つの選択ではあります。

コード:

Sub makeCSV(theSheet As Worksheet)
Dim iFile As Long, myPath As String
Dim myArr() As Variant, outStr As String
Dim iLoop As Long, jLoop As Long

myPath = Application.ActiveWorkbook.Path
iFile = FreeFile
Open myPath &"\myCSV.csv" For Output Lock Write As #iFile

myArr = theSheet.UsedRange
For iLoop = LBound(myArr, 1) To UBound(myArr, 1)
    outStr =""
    For jLoop = LBound(myArr, 2) To UBound(myArr, 2) - 1
        If InStr(1, myArr(iLoop, jLoop),",") Then
            outStr = outStr &"""" & myArr(iLoop, jLoop) &"""" &","
        Else
            outStr = outStr & myArr(iLoop, jLoop) &","
        End If
    Next jLoop
    If InStr(1, myArr(iLoop, jLoop),",") Then
        outStr = outStr &"""" & myArr(iLoop, UBound(myArr, 2)) &""""
    Else
        outStr = outStr & myArr(iLoop, UBound(myArr, 2))
    End If
    Print #iFile, outStr
Next iLoop

Close iFile
Erase myArr

End Sub