Speichern Sie jedes Blatt in einer Arbeitsmappe, um CSV-Dateien zu trennen

77

Wie speichere ich jedes Blatt in einer Excel-Arbeitsmappe, um CSVDateien mit einem Makro zu trennen ?

Ich habe ein Excel mit mehreren Blättern und ich suchte nach einem Makro, das jedes Blatt in einem separaten speichert CSV (comma separated file). In Excel können Sie nicht alle Blätter in verschiedenen CSVDateien speichern.

excel  vba  csv 
— Alex Duggleby
quelle

Antworten:

66

Hier ist eine, mit der Sie eine visuelle Dateiauswahl treffen können, um den Ordner auszuwählen, in dem Sie die Dateien speichern möchten, und in dem Sie auch das CSV-Trennzeichen auswählen können (ich verwende Pipes '|', da meine Felder Kommas enthalten und ich nicht behandeln möchte mit Anführungszeichen):

' ---------------------- 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
— HigherAbstraction
quelle
2
Da die Frage keinen nicht standardmäßigen Begrenzer erforderte, ist mir unklar, warum Sie eine Zelle für Zelle-Routine geschrieben haben. Wenn Sie diesen Weg beschreiten, arbeiten Sie mit varianten Arrays, die keine Bereiche sind, und berechnen Sie die UsedRangevor dem Verweis neu berechneten Arrays neu (entfernen Sie potenziellen überschüssigen Speicherplatz), verketten Sie die Longs-Strings mit kombinierten Short-Strings WholeLine = WholeLine & (CellValue & Sep), verwenden Sie String-Funktionen, keine Varianten ( Left$nicht Left) usw.
— brettdj
85

@AlexDuggleby: Sie müssen die Arbeitsblätter nicht kopieren, sondern können sie direkt speichern. z.B:

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

Das einzige mögliche Problem ist, dass Ihre Arbeitsmappe als letzte CSV-Datei gespeichert bleibt. Wenn Sie die ursprüngliche Arbeitsmappe behalten müssen, müssen Sie sie speichern.

— Graham
quelle
9
+1 Zur Verwendung in Excel können Sie: Alt + F11, Einfügen> Modul, Code einfügen, Klicken Sie auf die Wiedergabetaste.
— Bischof
Ein weiteres Problem funktioniert nicht, wenn es in Ihrer persönlichen Arbeitsmappe gespeichert ist. Ansonsten ausgezeichnet!
— Dylan Cross
@ Bischof, wie man diesen Code ausführt? Ich habe es im VBA-Editor in Excel 2016 auf MAC eingefügt, konnte es aber nicht ausführen. Ich erhalte diesen Fehler Laufzeitfehler '1004': Anwendungsdefinierter oder objektdefinierter Fehler
— Dinesh
7
Wenn Sie das SaveToDirectory ändern, stellen Sie sicher, dass Sie den nachfolgenden Backslash beibehalten.
— Jobo3208
Danke dafür! Seien Sie sich bewusst: Mir ist aufgefallen, dass wenn es eine gibt. Im Namen des Arbeitsblatts wird die Datumserweiterung .CSV nicht zum Dateinamen hinzugefügt.
— Craig Eddy
20

Und hier ist meine Lösung sollte mit Excel> 2000 funktionieren, aber erst 2007 getestet:

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: Ich frage mich, ob SO einige meiner kleinen Blogs ersetzen wird.)

— Alex Duggleby
quelle
2
Vielen Dank! Funktioniert in Office 2010. Es dauerte eine Weile, bis mir klar wurde, dass das nachfolgende "/" im Dateipfad weggelassen werden musste, da sonst Fehler auftreten
— TimoSolo
14

Aufbauend auf Grahams Antwort speichert der zusätzliche Code die Arbeitsmappe wieder im ursprünglichen Format an ihrem ursprünglichen Speicherort.

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
— Robert Mearns
quelle
Entschuldigung, aber warum müssen Sie die ursprüngliche Arbeitsmappe speichern? Sie können es einfach ohne Änderungen schließen, nicht wahr? Dann haben Sie auch schon alle CSV-Dateien erstellt.
— user3032689
Sie haben Recht, Sie müssen nicht. Dies hängt von Ihrem Workflow ab. Beim Speichern werden der Name und das Format der aktuellen Arbeitsmappe wiederhergestellt. Es bleibt dann offen, damit der Benutzer mit ihm interagieren kann. Wenn dies nicht getan wurde, ist der Name beim Versuch des Benutzers, es zu speichern, der Name des zuletzt verarbeiteten Blattes und das Format .csv. Wenn Sie die Arbeitsmappe nicht mehr benötigen, funktioniert ThisWorkbook.Close SaveChanges: = False genauso gut
— Robert Mearns
Ich sehe, das ist was du beabsichtigt hast :)
— user3032689
4

Eine kleine Änderung , um von Alex zu antworten, ist das Ein- und Ausschalten der automatischen Berechnung.

Überraschenderweise funktionierte der unveränderte Code mit VLOOKUP einwandfrei, schlug jedoch mit OFFSET fehl. Durch Deaktivieren der automatischen Berechnung wird das Speichern drastisch beschleunigt.

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
— Gemeinschaft
quelle
2
ActiveWorkbook.SaveAs Dateiname: = OutputFile, FileFormat: = xlCSV, CreateBackup: = False, Local: = True speichert Daten im lokalen Format
— Adam
1

Für Mac-Benutzer wie mich gibt es mehrere Fallstricke:

Sie können nicht in einem beliebigen Verzeichnis speichern. Nur wenige von ihnen können Ihre gespeicherten Dateien empfangen. Mehr Infos da

Hier ist ein funktionierendes Skript, das Sie kopieren und in Ihr Excel für Mac einfügen können:

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
quelle
+1 für den Mac. Zwei Dinge: 1. In der for-Schleifenleitung fehlt ein s- sollte ...ThisWorkbook.Worksheet*s* 2. Ich erhalte eine '[sheetname].csv' cannot be accessed Fehlermeldung. Seltsamerweise werden jedoch SaveToDirectory = './'alle Blätter erfolgreich in den ~/Library/Containers/com.microsoft.Excel/Data/Ordner exportiert , wenn ich den Pfad auf setze .
— Ken
0

Bitte schauen Sie in Von Pookies Antwort , alle Credits an ihn / sie.

 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
— Luigi Mackenzie C. Brito
quelle
Durch die Nutzung unserer Website bestätigen Sie, dass Sie unsere Cookie-Richtlinie und Datenschutzrichtlinie gelesen und verstanden haben.
Licensed under cc by-sa 3.0 with attribution required.