Сохраните каждый лист в книге для разделения файлов CSV

Как сохранить каждый лист в книге Excel для разделения файлов CSV с помощью макроса?

У меня есть excel с несколькими листами, и я искал макрос, который сохранит каждый лист в отдельном CSV (comma separated file) с разделителями- CSV (comma separated file) . Excel не позволит вам сохранять все листы в разных файлах CSV .

Вот один из них, который даст вам визуальный выбор файла, чтобы выбрать папку, в которую вы хотите сохранить файлы, а также позволяет выбрать разделитель CSV (я использую pipe ‘|’, потому что мои поля содержат запятые, и я не хочу заниматься с кавычками):

 ' ---------------------- 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 (eg, 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 

@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. Если вам нужно сохранить оригинальную книгу, вам понадобится SaveAs.

И вот мое решение должно работать с 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 

(OT: Интересно, заменит ли SO некоторые из моих второстепенных блогов)

Основываясь на ответе Грэма, дополнительный код сохраняет книгу в первоначальном месте в оригинальном формате.

 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 

Небольшая модификация ответа от Alex включает и выключает автоматический расчет.

Удивительно, но немодифицированный код работал отлично с 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 

Пожалуйста, зайдите в ответ Von Pookie , все кредиты ему / ей.

  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 
  • excel macro (VBA) для переноса нескольких столбцов в несколько строк
  • Поиск первой пустой строки, затем запись на нее
  • Как скопировать данные из закрытых книг (их закрытие) в основную книгу с помощью VBA
  • В Excel VBA, как мне сохранить / восстановить определяемый пользователем фильтр?
  • Как проверить пустой массив в макросе vba
  • Удалите задачу Excel из диспетчера задач после запуска из Access с помощью VBA
  • Перегрузка функций и UDF в Excel VBA
  • В Excel я вставил кучу URL-адресов, но они не являются живыми ссылками - как я могу преобразовать их в живые ссылки?
  • Проверьте, существует ли файл с использованием VBA
  • VBA: преобразовать текст в число
  • VBA Shell и подождите с кодом выхода
  • Давайте будем гением компьютера.