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

Question

如何将每个工作表保存在Excel工作簿中以使用宏分离CSV文件？

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

Answer 1

这里是一个会给你一个可视化文件选择器来选择你想要保存文件的文件夹，也可以让你选择CSV分隔符（我使用管道'|'，因为我的字段包含逗号，我不想处理报价）：

' ---------------------- 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 

Answer 2

这是我的解决方案应该用Excel> 2000，但只在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：我不知道如果这样将会取代我的一些小的部落格）

Answer 3

@AlexDuggleby：你不需要复制工作表，你可以直接保存它们。例如：

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 

只有潜在的问题是，您的工作簿保存为最后一个csv文件。如果您需要保留原始工作簿，则需要SaveAs。

Answer 4

基于Graham的答案，额外的代码将工作簿保存回原始格式的原始位置。

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 

Answer 5

小修改to answer from Alex打开和关闭自动计算。

令人惊讶的是，未经修改的代码与VLOOKUP一起工作正常，但失败了OFFSET。此外，关闭自动计算功能可大幅节省成本。

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 

Answer 6

请看Von Pookie's answer，所有学分给他/她。

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