excel - una - Guarde cada hoja en un libro de trabajo para separar archivos CSV

concatenar varias hojas de excel en una sola

Question

¿Cómo guardo cada hoja en un libro de Excel para separar archivos CSV con una macro?

Tengo un Excel con varias hojas y estaba buscando una macro que guarde cada hoja en un CSV (comma separated file) separado CSV (comma separated file) . Excel no le permitirá guardar todas las hojas en diferentes archivos CSV .

Answer 1

@AlexDuggleby: no necesita copiar las hojas de trabajo, puede guardarlas directamente. p.ej:

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

El único problema potencial es que eso deja su libro de trabajo guardado como el último archivo csv. Si necesita conservar el libro de trabajo original, deberá guardarlo.

Answer 2

Aquí hay uno que le dará un selector visual de archivos para elegir la carpeta en la que desea guardar los archivos y también le permite elegir el delimitador CSV (yo uso pipes ''|'' porque mis campos contienen comas y no quiero tratar con comillas):

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

Basándose en la respuesta de Graham, el código adicional guarda el libro de trabajo en su ubicación original en su formato original.

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 4

Mire la respuesta de Von Pookie , todos los créditos para él / ella.

 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

Answer 5

Una pequeña modificación a la respuesta de Alex es encender y apagar el cálculo automático.

Sorprendentemente, el código no modificado funcionaba bien con VLOOKUP pero falló con OFFSET. Además, la desactivación del cálculo automático acelera el ahorro drásticamente.

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

Y aquí está mi solución debería funcionar con Excel> 2000, pero probó solo en 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: Me pregunto si SO reemplazará algunos de mis blogs menores)