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

77

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

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

excel  vba  csv 
— 亚历克斯·杜格比
source

Answers:

65

这是一个可以为您提供视觉文件选择器的工具，您可以选择要将文件保存到的文件夹，还可以选择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
— 更高的抽象
source
2
由于该问题并未要求使用非标准的分隔符，因此我不清楚您为什么要按单元格编写例程。如果您沿这条路线使用变体数组而不是范围，请UsedRange在引用它之前重新计算（删除潜在的多余空间），将长字符串与短字符串组合起来WholeLine = WholeLine & (CellValue & Sep)，使用字符串函数而不是变体（Left$not Left）等
— brettdj
83

@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文件。如果需要保留原始工作簿，则需要另存为。

— 格雷厄姆
source
9
+1要在Excel中使用，可以执行以下操作：Alt + F11，插入>模块，粘贴代码，单击播放按钮。
— 主教
另一个问题，如果保存在您的个人工作簿中，则不起作用。否则优秀！
— Dylan Cross
@bishop如何运行此代码？我将其粘贴到Mac上的Excel 2016中的VBA编辑器中，但无法运行。我收到此错误运行时错误'1004'：应用程序定义或对象定义的错误
— Dinesh 2016年
7
如果更改SaveToDirectory，请确保保留结尾的反斜杠。
— jobo3208 '09
谢谢你！请注意：我注意到，如果有一个。在工作表的名称中，.CSV扩展名未添加到文件名中。
— Craig Eddy
20

这是我的解决方案应该适用于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：我想知道SO是否会取代我的一些次要博客）

— 亚历克斯·杜格比
source
2
谢谢！在Office 2010中的作品我花了一段意识到不得不离开关“/”结尾的文件路径，否则将提示错误
— TimoSolo
13

以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
— 罗伯特·梅恩斯
source
抱歉，为什么您需要保存原始工作簿？您可以不做任何更改就关闭它，对吗？然后，您还已经创建了所有.csv文件。
— user3032689
您是正确的，您不必这样做。这取决于您的工作流程。保存是恢复当前工作簿的名称和格式。然后，它保持打开状态以供用户进行交互。如果未这样做，则当用户尝试保存它时，该名称将是最后处理的工作表的名称，格式为.csv。如果您不再需要工作簿，则ThisWorkbook.Close SaveChanges：= False也可以工作
— Robert Mearns
我明白了，这就是您的意图：)
— user3032689
4

从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
— 社区
source
2
ActiveWorkbook.SaveAs文件名：= OUTPUTFILE，的FileFormat：= xlCSV，CreateBackup：=假本地：=真会使用本地格式保存日期
— 亚当
1

对于像我这样的Mac用户，有一些陷阱：

您无法保存到任何目录。他们中只有少数人可以接收您保存的文件。那里有更多信息

这是一个工作脚本，您可以在Mac的excel中复制粘贴：

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
— Żabojad
source
+1（在Mac上使用）。两件事：1. for循环行缺少s-应该为...ThisWorkbook.Worksheet*s* 2.我收到'[sheetname].csv' cannot be accessed 错误。但是，奇怪的是，如果将路径设置为SaveToDirectory = './'，则所有工作表都已成功导出到该~/Library/Containers/com.microsoft.Excel/Data/文件夹。
— 肯
By using our site, you acknowledge that you have read and understand our Cookie Policy and Privacy Policy.
Licensed under cc by-sa 3.0 with attribution required.