将工作簿中的每个工作表保存为单独的 CSV 文件

如何保存 Excel 工作簿中的每个工作表,以便用宏分隔 CSV文件?

我有一个与多个工作表的 Excel,我正在寻找一个宏,将保存每个工作表到一个单独的 CSV (comma separated file)。Excel 不允许您将所有工作表保存到不同的 CSV文件。

147815 次浏览

And here's my solution should work with Excel > 2000, but tested only on 2007:

Private Sub SaveAllSheetsAsCSV()
On Error GoTo Heaven


' each sheet reference
Dim Sheet As Worksheet
' path to output to
Dim OutputPath As String
' name of each csv
Dim OutputFile As String


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False


' ask the user where to save
OutputPath = InputBox("Enter a directory to save to", "Save to directory", Path)


If OutputPath <> "" Then


' save for each sheet
For Each Sheet In Sheets


OutputFile = OutputPath & "\" & Sheet.Name & ".csv"


' make a copy to create a new book with this sheet
' otherwise you will always only get the first sheet
Sheet.Copy
' this copy will now become active
ActiveWorkbook.SaveAs FileName:=OutputFile, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next


End If


Finally:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True


Exit Sub


Heaven:
MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _
"Source: " & Err.Source & " " & vbCrLf & _
"Number: " & Err.Number & " " & vbCrLf & _
"Description: " & Err.Description & " " & vbCrLf


GoTo Finally
End Sub

(OT: I wonder if SO will replace some of my minor blogging)

Here is one that will give you a visual file chooser to pick the folder you want to save the files to and also lets you choose the CSV delimiter (I use pipes '|' because my fields contain commas and I don't want to deal with quotes):

' ---------------------- Directory Choosing Helper Functions -----------------------
' Excel and VBA do not provide any convenient directory chooser or file chooser
' dialogs, but these functions will provide a reference to a system DLL
' with the necessary capabilities
Private Type BROWSEINFO    ' used by the function GetFolderName
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type


Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long


Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer
bInfo.pidlRoot = 0&    ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
' the dialog title
Else
bInfo.lpszTitle = Msg    ' the dialog title
End If
bInfo.ulFlags = &H1    ' Type of directory to return
X = SHBrowseForFolder(bInfo)    ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName = ""
End If
End Function
'---------------------- END Directory Chooser Helper Functions ----------------------


Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim csvPath As String




Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", _
"Export To Text File")
'csvPath = InputBox("Enter the full path to export CSV files to: ")


csvPath = GetFolderName("Choose the folder to export CSV files to:")
If csvPath = "" Then
MsgBox ("You didn't choose an export directory. Nothing will be exported.")
Exit Sub
End If


For Each wsSheet In Worksheets
wsSheet.Activate
nFileNum = FreeFile
Open csvPath & "\" & _
wsSheet.Name & ".csv" For Output As #nFileNum
ExportToTextFile CStr(nFileNum), Sep, False
Close nFileNum
Next wsSheet


End Sub






Public Sub ExportToTextFile(nFileNum As Integer, _
Sep As String, SelectionOnly As Boolean)


Dim WholeLine As String
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String


Application.ScreenUpdating = False
On Error GoTo EndMacro:


If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If


For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #nFileNum, WholeLine
Next RowNdx


EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True


End Sub

@AlexDuggleby: you don't need to copy the worksheets, you can save them directly. e.g.:

Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String


SaveToDirectory = "C:\"


For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name, xlCSV
Next


End Sub

Only potential problem is that that leaves your workbook saved as the last csv file. If you need to keep the original workbook you will need to SaveAs it.

Building on Graham's answer, the extra code saves the workbook back into it's original location in it's original format.

Public Sub SaveWorksheetsAsCsv()


Dim WS As Excel.Worksheet
Dim SaveToDirectory As String


Dim CurrentWorkbook As String
Dim CurrentFormat As Long


CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
' Store current details for the workbook


SaveToDirectory = "C:\"


For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name, xlCSV
Next


Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
Application.DisplayAlerts = True
' Temporarily turn alerts off to prevent the user being prompted
'  about overwriting the original file.


End Sub

A small modification to answer from Alex is turning on and off of auto calculation.

Surprisingly the unmodified code was working fine with VLOOKUP but failed with OFFSET. Also turning auto calculation off speeds up the save drastically.

Public Sub SaveAllSheetsAsCSV()
On Error GoTo Heaven


' each sheet reference
Dim Sheet As Worksheet
' path to output to
Dim OutputPath As String
' name of each csv
Dim OutputFile As String


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False


' Save the file in current director
OutputPath = ThisWorkbook.Path




If OutputPath <> "" Then
Application.Calculation = xlCalculationManual


' save for each sheet
For Each Sheet In Sheets


OutputFile = OutputPath & Application.PathSeparator & Sheet.Name & ".csv"


' make a copy to create a new book with this sheet
' otherwise you will always only get the first sheet


Sheet.Copy
' this copy will now become active
ActiveWorkbook.SaveAs Filename:=OutputFile, FileFormat:=xlCSV,     CreateBackup:=False
ActiveWorkbook.Close
Next


Application.Calculation = xlCalculationAutomatic


End If


Finally:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True


Exit Sub


Heaven:
MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _
"Source: " & Err.Source & " " & vbCrLf & _
"Number: " & Err.Number & " " & vbCrLf & _
"Description: " & Err.Description & " " & vbCrLf


GoTo Finally
End Sub

Please look into Von Pookie's answer, all credits to him/her.

 Sub asdf()
Dim ws As Worksheet, newWb As Workbook


Application.ScreenUpdating = False
For Each ws In Sheets(Array("EID Upload", "Wages with Locals Upload", "Wages without Local Upload"))
ws.Copy
Set newWb = ActiveWorkbook
With newWb
.SaveAs ws.Name, xlCSV
.Close (False)
End With
Next ws
Application.ScreenUpdating = True


End Sub

For Mac users like me, there are several gotchas:

You cannot save to any directory you want. Only few of them can receive your saved files. More info there

Here is a working script that you can copy paste in your excel for Mac:

Public Sub SaveWorksheetsAsCsv()


Dim WS As Excel.Worksheet
Dim SaveToDirectory As String


SaveToDirectory = "~/Library/Containers/com.microsoft.Excel/Data/"


For Each WS In ThisWorkbook.Worksheet
WS.SaveAs SaveToDirectory & WS.Name & ".csv", xlCSV
Next


End Sub


Use Visual Basic to loop through worksheets and save .csv files.

  1. Open up .xlsx file in Excel.

  2. Press option+F11

  3. InsertModule

  4. Insert this into the module code:

    Public Sub SaveWorksheetsAsCsv()
    
    
    Dim WS As Excel.Worksheet
    Dim SaveToDirectory As String
    
    
    SaveToDirectory = "./"
    
    
    For Each WS In ThisWorkbook.Worksheets
    WS.SaveAs SaveToDirectory & WS.Name & ".csv", xlCSV
    Next
    
    
    End Sub
    
  5. Run the module.

    (i.e. Click the play button at the top and then click "Run" on the dialog, if it pops up.)

  6. Find your .csv files in ~/Library/Containers/com.microsoft.Excel/Data.

    open ~/Library/Containers/com.microsoft.Excel/Data
    
  7. Close .xlsx file.

  8. Rinse and repeat for other .xlsx files.