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

Question

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

Ich habe eine Excel mit mehreren Blättern und ich war auf der Suche nach einem Makro, das jedes Blatt zu einem separaten CSV (comma separated file) speichert. Excel erlaubt Ihnen nicht, alle Blätter in verschiedenen CSV Dateien zu speichern.

Answer 1

Hier ist eine, die Ihnen eine visuelle Dateiauswahl bietet, um den Ordner auszuwählen, in dem Sie die Dateien speichern möchten, und Sie können auch das CSV-Trennzeichen auswählen (Ich benutze Pipes '|', da meine Felder Kommas enthalten und ich nicht damit umgehen möchte) Zitate):

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

Und hier ist meine Lösung soll mit Excel arbeiten> 2000, aber getestet nur auf 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: Ich frage mich also, wenn einige von meinen kleineren Bloggen ersetzen)

Answer 3

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

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 

Nur mögliches Problem ist, dass Ihre Arbeitsmappe als die letzte CSV-Datei gespeichert bleibt. Wenn Sie die ursprüngliche Arbeitsmappe beibehalten möchten, müssen Sie sie speichern.

Answer 4

Aufbauend auf Grahams Antwort speichert der zusätzliche Code die Arbeitsmappe 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 

Answer 5

Eine kleine Änderung to answer from Alex wird das Ein- und Ausschalten der automatischen Berechnung.

Überraschenderweise funktionierte der unmodifizierte Code mit SVERWEIS, aber mit OFFSET fehlgeschlagen. Wenn Sie die automatische Berechnung ausschalten, 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 

Answer 6

Bitte schauen Sie in Von Pookie's answer, alle Kredite an ihm/ihr.

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