Zapisz każdy arkusz w skoroszycie, aby oddzielić pliki CSV

Question

Jak zapisać każdy arkusz w skoroszycie programu Excel, aby oddzielić pliki CSV od makra?

Mam program Excel z wieloma arkuszami i szukałem makra, które zapisze każdy arkusz do osobnego CSV (comma separated file). Program Excel nie zezwoli na zapisywanie wszystkich arkuszy w różnych plikach CSV.

Answer 1

Tutaj to taki, który da ci wizualny selektor plików, by wybrać folder, do którego chcesz zapisać pliki, a także pozwala ci wybrać ogranicznik CSV (używam potoku '|', ponieważ moje pola zawierają przecinki i nie chcę zajmować się nimi Cytaty):

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

A oto moje rozwiązanie powinno działać z programem Excel> 2000, ale testowane tylko na 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: Zastanawiam się, czy tak będzie zastąpić niektóre z moich drobnych blogowania)

Answer 3

@AlexDuggleby: nie musisz kopiować arkuszy, możesz je zapisać bezpośrednio. np .:

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 

Jedynym potencjalnym problemem jest to, że pozostawia skoroszyt zapisany jako ostatni plik CSV. Jeśli chcesz zachować oryginalny skoroszyt, musisz go zapisać.

Answer 4

W oparciu o odpowiedź Grahama, dodatkowy kod zapisuje skoroszyt z powrotem do oryginalnej lokalizacji w oryginalnym formacie.

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

Mała modyfikacja to answer from Alex włącza się i wyłącza automatycznego obliczania.

Co zaskakujące, niezmodyfikowany kod działał poprawnie z funkcją WYSZUKAJ.PIONOWO, ale zakończył się niepowodzeniem z PRZESUNIĘCIEM. Również wyłączenie automatycznego obliczania przyspiesza oszczędzanie drastycznie.

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

Proszę spojrzeć Von Pookie's answer, wszystkie kredyty do niego/niej.

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