Lưu từng trang tính trong sổ làm việc để tách các tệp CSV

Question

Làm cách nào để lưu từng trang tính trong sổ làm việc Excel để tách các tệp CSV có macro?

Tôi có một excel với nhiều trang tính và tôi đang tìm kiếm macro sẽ lưu từng trang tính vào CSV (comma separated file) riêng biệt. Excel sẽ không cho phép bạn lưu tất cả các trang tính thành các tệp CSV khác nhau.

Answer 1

đây là một trong đó sẽ cung cấp cho bạn một trình chọn tệp hình ảnh để chọn thư mục bạn muốn lưu tệp và cũng cho phép bạn chọn dấu phân cách CSV (tôi sử dụng đường ống '|' vì các trường của tôi chứa dấu phẩy và tôi không muốn xử lý báo giá):

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

Và đây là giải pháp của tôi sẽ làm việc với Excel> 2000, nhưng chỉ được thử nghiệm trên 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: Tôi tự hỏi nếu SO sẽ thay thế một số blog nhỏ của tôi)

Answer 3

@AlexDuggleby: bạn không cần phải sao chép các trang tính, bạn có thể lưu chúng trực tiếp. ví dụ:

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 

Chỉ có vấn đề có thể khiến sổ làm việc của bạn được lưu dưới dạng tệp csv cuối cùng. Nếu bạn cần giữ sổ làm việc ban đầu, bạn sẽ cần SaveAs nó.

Answer 4

Xây dựng dựa trên câu trả lời của Graham, mã phụ sẽ lưu sổ làm việc trở lại vị trí ban đầu của nó ở định dạng gốc.

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

Chỉnh sửa nhỏ to answer from Alex được bật và tắt tính toán tự động.

Đáng ngạc nhiên là mã chưa sửa đổi đã hoạt động tốt với VLOOKUP nhưng không thành công với OFFSET. Ngoài ra, tính toán tự động giảm tốc độ tiết kiệm đáng kể.

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

Vui lòng xem xét Von Pookie's answer, tất cả tín dụng cho người đó.

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