Based on some other stuff I found here, I have made the following script to do almost exactly what I want. It will export all but 4 specific sheets in an excel file to CSV files, append dates to them, and save them to dated folders. The only problem is it renames the sheets it exported in the original processing file. How can I rectify this?
Sub SaveLCPWorksheetsAsCsv()
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:\test\" & Format(Date - 1, "YYYYMM") & "\"
If Len(Dir(SaveToDirectory, vbDirectory)) = 0 Then
MkDir SaveToDirectory
End If
For Each WS In ThisWorkbook.Worksheets
If WS.Name <> "Input" And WS.Name <> "Ref" And WS.Name <> "Total" And WS.Name <> "Affected Accounts" Then
WS.SaveAs SaveToDirectory & WS.Name & "_" & Format(Date - 1, "YYYYMMDD"), xlCSV
End If
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
Sub Tester()
Dim ws As Worksheet, wb As Workbook
For Each ws In ThisWorkbook.Worksheets
ws.Copy 'creates a new workbook
With ActiveWorkbook
.SaveAs "C:\temp\" & ws.Name & "_blah.csv", xlCSV
.Close False
End With
Next ws
End Sub
Related
I'm still working on learning VBA, so this might be a dumb question, but I'm looking to loop through a workbook of ~ 90-95 sheets, break each out into its own workbook, and save it as the name of the worksheet from the original file.
The script works, but only if I comment out the .Worksheets(1).Delete, and I'm wondering why...It throws a 1004 error on both sheets that I'm running it against, but not in the same spot. The first sheet errors out on tab 4, the second on tab 40-something.
Right now I've got the FileNamePrefix variable set up to toggle, because I'm running this in the VBA window under "ThisWorkbook", since I haven't figured out how to run this macro from its own sheet, and choose the prefix based on the name/extension of the file it maps to. (AC comes to me as a .xlsm, CC as a .xlsx) That is still on my to-do, so no spoilers, please! :)
Macro:
Sub Sheet_SaveAs()
Dim wb As Workbook
Dim WS_Count As Integer
Dim ActiveSheetName As String
Dim ws As Worksheet
Dim FileNamePrefix As String
Dim FileName As String
Dim FilePath As String
'FileNamePrefix = "CC Dashboard "
FileNamePrefix = "AC Dashboard "
WS_Count = ActiveWorkbook.Worksheets.Count
MsgBox (" This will create: " & WS_Count & " Files")
For Each ws In ThisWorkbook.Worksheets
Set wb = Workbooks.Add(xlWBATWorksheet)
With wb
ThisWorkbook.Worksheets(ws.Name).Copy After:=.Worksheets(.Worksheets.Count)
Application.DisplayAlerts = False
.Worksheets(1).Delete
Application.DisplayAlerts = True
.SaveAs ThisWorkbook.Path & "\" & FileNamePrefix & ws.Name
.Close False
End With
ws.Name = FileNamePrefix & ws.Name
Next
MsgBox (" Done! ")
End Sub
So lets get rid of the Delete and just create the new file with only the worksheet you want. I also did a little clean up on your code.
Sub Sheet_SaveAs()
Dim wb As Workbook
Dim WS_Count As Integer
Dim ActiveSheetName, FileNamePrefix, FileName, FilePath As String
Dim ws As Worksheet
'FileNamePrefix = "CC Dashboard "
FileNamePrefix = "AC Dashboard "
WS_Count = ActiveWorkbook.Worksheets.Count
MsgBox (" This will create: " & WS_Count & " Files")
For Each ws In ThisWorkbook.Worksheets
ws.Copy 'this creates a new file with only the one sheet, so no Delete needed
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & FileNamePrefix & ws.Name
ActiveWorkbook.Close False
Next
MsgBox (" Done! ")
End Sub
I've got this Macro working beautifully, but every now and again it will save the exported sheets into the last folder I was working in, and not the specific folder I want them in. How do I specify the folder they should go into?
Sub asdf()
Dim ws As Worksheet, newWb As Workbook
Application.ScreenUpdating = False
For Each ws In Sheets(Array("sheet1", "sheet2", "sheet3"))
ws.Copy
Set newWb = ActiveWorkbook
With newWb
.SaveAs ws.Name & ".csv", xlCSVWindows
.Close (False)
End With
Next ws
Application.ScreenUpdating = True
End Sub
You need to specify the location you want it saved to in the code.
Try this.
.SaveAs FileName:="C:\OutputFilepath\" & ws.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
Replace this line
.SaveAs ws.Name & ".csv", xlCSVWindows
With
.SaveAs "D:\MyFolder\" & ws.Name & ".csv", xlCSVWindows
Change the "D:\MyFolder\" to your desired path.
Add a string type var that contains the full path to the folder. In the following example, I'll use the temp directory.
Sub asdf()
Dim ws As Worksheet, newWb As Workbook, fp as string
fp = environ("TEMP") & Chr(92)
'could be something like
'fp = environ("USER") & "\desktop\"
Application.ScreenUpdating = False
For Each ws In Sheets(Array("sheet1", "sheet2", "sheet3"))
ws.Copy
Set newWb = ActiveWorkbook
With newWb
.SaveAs fp & ws.Name, xlCSVWindows 'add the path, let saveas add the extension
.Close savechanges:=False
End With
Next ws
Application.ScreenUpdating = True
End Sub
I created a macro that saves the value of an .xlsx file to a csv in a certain directory with the name of the csv = to the name of the Excel file which it was written from.
I wanted this macro to be available in any spreadsheet/workbook so I saved and added it as an add in.
I think I am having issues with ActiveWorkbook vs Thisworkbook.
The following code is the original that works as intended when not used as an add in:
Sub CSV()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
SaveToDirectory = "C:\SomeDirectory\"
For Each WS In ThisWorkbook.Worksheets
Sheets(WS.Name).Copy
ActiveWorkbook.SaveAs Filename:=SaveToDirectory & ThisWorkbook.Name & ".csv", FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
Next
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
Application.DisplayAlerts = False
End Sub
However if that code is used in the add in, the file saves with the name of the add in. So I changed the code and used ActiveWorkbook but it appears the value gets changed when it is time to save.
Sub CSV2()
On Error GoTo error_handler
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
CurrentWorkbook = ActiveWorkbook.Name
CurrentFormat = ActiveWorkbook.FileFormat
SaveToDirectory = "C:\SomeDirectory\"
For Each WS In ActiveWorkbook.Worksheets
Sheets(WS.Name).Copy
ActiveWorkbook.SaveAs Filename:=SaveToDirectory & ThisWorkbook.Name & ".csv", FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
Next
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
Application.DisplayAlerts = False
error_handler:
MsgBox Err.Description
End Sub
I want to write my Excel file to csv. Save that CSV in the directory that is defined. With the name of the csv = the name of the file that the information is coming from. And to be able to do this in any workbook I open.
Try this code:
Sub CSV2()
On Error GoTo error_handler
Dim aWB As Workbook
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
Set aWB = ActiveWorkbook
CurrentWorkbook = aWB.Name
CurrentFormat = aWB.FileFormat
SaveToDirectory = "C:\SomeDirectory\"
For Each WS In aWB.Worksheets
WS.Copy
ActiveWorkbook.SaveAs Filename:=SaveToDirectory & aWB.Name & "_" & WS.Name & ".csv", FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
'ThisWorkbook.Activate
Next
Application.DisplayAlerts = False
aWB.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
Application.DisplayAlerts = False
Exit Sub
error_handler:
MsgBox Err.Description
End Sub
I add ws.name after awb.name to prevent the same file name.
I have found a decent solution Saving excel worksheet to CSV files with filename+worksheet name using VB for saving all worksheets in a workbook as CSV files. However, I would like to be able to modify this code to only save worksheets where the sheet name ends with _t.
I am using the following code:
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 = "H:\test\"
For Each WS In ThisWorkbook.Worksheets
Sheets(WS.Name).Copy
ActiveWorkbook.SaveAs Filename:=SaveToDirectory & ThisWorkbook.Name & "-" & WS.Name & ".csv", FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
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
Can this be done?
Use the Right or Instr-Method on the worksheet.name property to get the last characters / check if your searchstring is exisiting.
In your for each-loop add the following code:
If Right(WS.name, 2) = "_t" Then
Sheets(WS.Name).Copy
ActiveWorkbook.SaveAs Filename:=SaveToDirectory & ThisWorkbook.Name & "-" & WS.Name & ".csv", FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
End if
Hi I am trying to use this code to save each sheet of Excel to a new workbook. However, it is saving the entire workbook to the new filename
Dim path As String
Dim dt As String
dt = Now()
path = CreateObject("WScript.Shell").specialfolders("Desktop") & "\Calendars " & Replace(Replace(dt, ":", "."), "/", ".")
MkDir path
Call Shell("explorer.exe" & " " & path, vbNormalFocus)
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets 'SetVersions
If ws.name <> "How-To" And ws.name <> "Actg_Prd" Then
ws.SaveAs path & ws.name, xlsx
End If
Next ws
What is the quick fix?
Keeping the worksheet in the existing workbook and creating a new workbook with a copy
Dim path As String
Dim dt As String
dt = Now()
path = CreateObject("WScript.Shell").specialfolders("Desktop") & "\Calendars " & Replace(Replace(dt, ":", "."), "/", ".")
MkDir path
Call Shell("explorer.exe" & " " & path, vbNormalFocus)
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets 'SetVersions
If ws.Name <> "How-To" And ws.Name <> "Actg_Prd" Then
Dim wb As Workbook
Set wb = ws.Application.Workbooks.Add
ws.Copy Before:=wb.Sheets(1)
wb.SaveAs path & ws.Name, Excel.XlFileFormat.xlOpenXMLWorkbook
Set wb = Nothing
End If
Next ws
I recommend introducing some error checking so as to ensure the folder you'll ultimately try to save workbooks to, actually exists. This will also create the folder relative to wherever you've saved your macro-enabled excel file.
On Error Resume Next
MkDir ThisWorkbook.path & "\Calendars\"
On Error GoTo 0
I also highly recommend closing the newly created workbook as soon as it's saved. If you are trying to create a large number of new workbooks, you'll quickly find how much it lags your system.
wb.Close
Moreover, Sorceri's code will not save an excel file with the appropriate file extension. You must specify that in the file name.
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets 'SetVersions
If ws.Name <> "How-To" And ws.Name <> "Actg_Prd" Then
Dim wb As Workbook
Set wb = ws.Application.Workbooks.Add
ws.Copy Before:=wb.Sheets(1)
wb.SaveAs path & ws.Name & ".xlsx", Excel.XlFileFormat.xlOpenXMLWorkbook
wb.Close
Set wb = Nothing
End If
Next ws