将每个工作表保存在工作簿中以分隔CSV文件 [英] Save each sheet in a workbook to separate CSV files

问题描述

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

How do I save each sheet in an Excel workbook to separate CSV files with a macro?

有一个excel与多个表，我正在寻找一个宏，将保存每个表单独的 CSV（逗号分隔的文件）。 Excel不允许您将所有工作表保存到不同的 CSV 文件。

I have an excel with multiple sheets and I was looking for a macro that will save each sheet to a separate CSV (comma separated file). Excel will not allow you to save all sheets to different CSV files.

推荐答案

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

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

这篇关于将每个工作表保存在工作簿中以分隔CSV文件的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！