VBA_ブック内の全シートを一括してCSV化する - ekuserutoka @ ウィキ

//xlsVBA
//http://www.h-fj.com/blog/archives/2014/01/07-105447.php
//multiexport.xlsm!ExportFilesToCSV

Rem Attribute VBA_ModuleType=VBAModule
Sub Module1
Rem Option Explicit
Rem
Rem Sub ExportFilesToCSV()
Rem     ExportFiles xlCSV
Rem End Sub
Rem
Rem Sub ExportFilesToTSV()
Rem     ExportFiles xlText
Rem End Sub
Rem
Rem Sub ExportFiles(frm As XlFileFormat)
Rem     ' ブックが保存済みでない場合は保存
Rem     If ActiveWorkbook.Saved = False Then
Rem         If MsgBox("ブックがまだ保存されていません。保存しますか？", vbYesNo) = vbNo Then
Rem             Exit Sub
Rem         Else
Rem             ActiveWorkbook.Save
Rem         End If
Rem     End If
Rem
Rem     ' 出力先フォルダを選択
Rem     Dim fd As FileDialog, fld As String
Rem     fld = ActiveWorkbook.Path
Rem     If Right(fld, 1) <> "\" Then
Rem         fld = fld & "\"
Rem     End If
Rem     Set fd = Application.FileDialog(msoFileDialogFolderPicker)
Rem     fd.Title = "出力先フォルダの選択"
Rem     fd.AllowMultiSelect = False
Rem     fd.InitialFileName = fld
Rem     If fd.Show = False Then Exit Sub
Rem     fld = fd.SelectedItems(1)
Rem     If Right(fld, 1) <> "\" Then
Rem         fld = fld & "\"
Rem     End If
Rem
Rem     ' 書き出し
Rem     Dim ws As Worksheet, fname As String, ext As String, wbPath, f As Boolean
Rem     Application.DisplayAlerts = False
Rem     Application.ScreenUpdating = False
Rem     wbPath = ActiveWorkbook.FullName
Rem     If frm = xlCSV Then
Rem         ext = ".csv"
Rem     Else
Rem         ext = ".tsv"
Rem     End If
Rem     For Each ws In ActiveWorkbook.Worksheets
Rem         f = False
Rem         ws.Activate
Rem         fname = fld & ws.Name & ext
Rem         If Dir(fname) <> "" Then
Rem             f = (MsgBox(fname & "が存在します。上書きしますか？", vbYesNo) = vbYes)
Rem         Else
Rem             f = True
Rem         End If
Rem         If f Then
Rem             ActiveWorkbook.SaveAs Filename:=fname, FileFormat:=frm
Rem         End If
Rem     Next
Rem     ActiveWorkbook.Close
Rem     Workbooks.Open wbPath
Rem     Application.DisplayAlerts = True
Rem     Application.ScreenUpdating = True
Rem     MsgBox "書き出しが終了しました"
Rem End Sub
End Sub