Збережіть кожен аркуш у книзі, щоб відокремити файли CSV


77

Як зберегти кожен аркуш у книзі Excel, щоб відокремити CSVфайли за допомогою макросу?

У мене є Excel з декількома аркушами, і я шукав макрос, який збереже кожен аркуш на окремому CSV (comma separated file). Excel не дозволить вам зберігати всі аркуші у різних CSVфайлах.

Відповіді:


66

Ось той, який дасть вам візуальний засіб вибору файлів, щоб вибрати папку, до якої ви хочете зберегти файли, а також дозволить вам вибрати роздільник CSV (я використовую конвеєри '|', оскільки мої поля містять коми, і я не хочу мати справу з цитатами):

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

2
Оскільки питання не вимагало нестандартного роздільника, мені незрозуміло, чому ви писали клітинку за рутинною процедурою. Якщо ви йдете цим маршрутом, працюйте з масивами варіантів, а не діапазонами, повторіть повторення UsedRangeперед посиланням на нього (видаліть потенційний зайвий простір), об'єднайте рядки longs з комбінованими короткими рядками WholeLine = WholeLine & (CellValue & Sep), використовуйте функції рядків , а не варіанти ( Left$not Left) тощо
brettdj

85

@AlexDuggleby: вам не потрібно копіювати робочі аркуші, ви можете зберегти їх безпосередньо. наприклад:

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

Єдина потенційна проблема полягає в тому, що ваша книга зберігається як останній файл csv. Якщо вам потрібно зберегти оригінал робочої книги, вам потрібно буде зберегти як це.


9
+1 Для використання в Excel можна: Alt + F11, Вставити> Модуль, Вставити код, Клацнути кнопку відтворення.
єпископ

Інша проблема - не працює, якщо вона зберігається у вашій особистій книзі. Інакше Відмінно!
Ділан Крос

@bishop як запустити цей код? Я вставив його у редактор VBA в Excel 2016 на MAC, але не зміг запустити. Я отримую цю помилку Помилка під час виконання '1004': Помилка, визначена додатком або визначена об'єктом
Dinesh

7
Якщо ви змінюєте SaveToDirectory, переконайтеся, що ви зберігаєте кінцеву зворотну риску.
jobo3208

Дякую за це! Майте на увазі: я помітив, що якщо є. в назві робочого аркуша розширення .CSV не додається до імені файлу.
Крейг Едді,

20

І ось моє рішення має працювати з Excel> 2000, але протестоване лише в 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

(ВЗ: Цікаво, чи ТО замінить деякі мої незначні блоги)


2
Дякую! Працює в Office 2010. Мені знадобився деякий час, щоб зрозуміти, що потрібно залишити кінцевий "/" у шляху до файлу, інакше видає помилки
TimoSolo

14

Спираючись на відповідь Грема, додатковий код зберігає книгу назад у вихідному місці у оригінальному форматі.

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

вибачте, але навіщо потрібно зберігати оригінальну книгу? Ви можете просто закрити його без змін, чи не так? Тоді ви також створили всі файли .csv раніше.
user3032689

Ви маєте рацію, не потрібно. Це залежить від вашого робочого процесу. Збереження полягає у відновленні поточної назви книги та формату. Потім користувач залишає його відкритим для взаємодії. Якщо цього не було зроблено, тоді, коли користувач намагається зберегти його, ім'ям буде ім'я останнього обробленого аркуша та формат .csv. Якщо вам більше не потрібна робоча книга, тоді ThisWorkbook.Close SaveChanges: = False спрацював би так само добре
Роберт Мернс,

Я бачу, це те, що ви задумали :)
user3032689

4

Невелика модифікація для відповіді від Алекса включає та вимикає автоматичний розрахунок.

На диво, немодифікований код працював нормально з VLOOKUP, але не зміг з OFFSET. Також вимкнення автоматичного обчислення значно прискорює економію.

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

2
ActiveWorkbook.SaveAs Ім'я файлу: = OutputFile, FileFormat: = xlCSV, CreateBackup: = False, Local: = True збереже дати, використовуючи локальний формат
Адам,

1

Для таких користувачів Mac, як я, існує кілька проблем:

Ви не можете зберегти в будь-якому каталозі, який ви хочете. Лише небагато з них можуть отримати ваші збережені файли. Більше інформації там

Ось робочий скрипт, який ви можете скопіювати, вставити у ваш Excel для Mac:

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


+1 для використання на Mac. Дві речі: 1. У рядку циклу for відсутній s- повинен бути ...ThisWorkbook.Worksheet*s* 2. Я отримую повідомлення про '[sheetname].csv' cannot be accessed помилку. Як не дивно, але якщо я встановив шлях SaveToDirectory = './', усі аркуші успішно експортуються до ~/Library/Containers/com.microsoft.Excel/Data/папки.
Кен

0

Будь ласка, ознайомтесь із відповіддю фон Пукі , усі кредити йому / їй.

 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
Використовуючи наш веб-сайт, ви визнаєте, що прочитали та зрозуміли наші Політику щодо файлів cookie та Політику конфіденційності.
Licensed under cc by-sa 3.0 with attribution required.