I want to write an VBA makro to save selected excel sheets as csv files. What did I collect up to know:
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
SaveToDirectory = "G:\...\Create csv\" & Format(Date, "YYYYMMDD") & "_csv Save" & "\"
If Len(Dir(SaveToDirectory, vbDirectory)) = 0 Then
MkDir SaveToDirectory
End If
For Each WS In ThisWorkbook.Worksheets
If WS.Name = "Government_debt" Or WS.Name = "Domestic_demand" Or (...) Then
WS.SaveAs SaveToDirectory & WS.Name, xlCSV
End If
Next
What do I need to complete it?
I need the time after the date, in case I need to run the makro twice a day.
"YYYYMMDDHHMM" as solution gives me 201504280000
I want to create the directory in that way, that it is the folder of the file, in which the makro is. I tried already CurDir() and Application.ActiveWorkbook.Path but without success
I want to exclude some excel sheets instead of choosing only the ones to save. E.g I have some sheets "calc_(...)" which I do not need. How can I do that.
Thanks in advance!
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 have been able to get some code to open the most up to date file located on a share drive. The part of code that i'm really struggling with is the last part which tries to copy and paste the contents of that file into my master - i tried recording this last part and alter that code but have had no luck - i feel like im on the right track but would appreciate any pointers! the specific error is "Run-time error '1004'"
Sub GetLatestFile()
Dim strFolder As String
Dim strFile As String
Dim latestFile As String
Dim dtLast As Date
' assign variables
strFolder = "Z:\PRICING1\1Mbs Pricing1\MBSREVAL11\21016111\" 'The end of this path must have a \ on it
strFile = Dir(strFolder & "\*.*", vbNormal) ' Any File
' strFile = Dir(strFolder & "\*.xls*", vbNormal) ' Excel Files
' strFile = Dir(strFolder & "\*.csv", vbNormal) ' CSV Files
' loop through files to find latest modified date
Do While strFile <> ""
If FileDateTime(strFolder & strFile) > dtLast Then
dtLast = FileDateTime(strFolder & strFile)
latestFile = strFolder & strFile
End If
strFile = Dir
Loop
MsgBox latestFile
Workbooks.Open (latestFile)
Worksheets("Ratesheet").Activate
Range(A7).Select
Selection.copy
Windows("RMBS Pricing_New v5 (version 1) [Autosaved]").Activate
Range("A7").Select
ActiveSheet.Paste
Windows(latestFile).Activate
End Sub
Assuming that RMBS ... is the master file:
Workbooks.Open(latestFile)
Worksheets("Ratesheet").Activate
Range("A7").Select
Selection.copy
' ActiveWorkbook.Close if needed
Workbooks.Open("RMBS Pricing_New v5 (version 1) [Autosaved]")
Range("A7").Select
Selection.Paste
' Save/close as needed
This is the simplest way to achieve what you want. Avoid the use of .Select/.Activate. You may want to see THIS
My Assumptions:
The file that you are trying to open can be opened in Excel
You are running the code from RMBS Pricing_New v5 (version 1). If not then declare another workbook object and assign this workbook to that object.
Is this what you are trying? (Untested)
Sub GetLatestFile()
Dim strFolder As String, strFile As String, latestFile As String
Dim dtLast As Date
Dim wbThis As Workbook, wbThat As Workbook
Dim wsThis As Worksheet, wsThat As Worksheet
Set wbThis = ThisWorkbook
'<~~ Change this to the relevant sheetname where you want to paste
Set wsThis = wbThis.Sheets("Sheet1")
'
'~~> Your code to find the latest file
'
Set wbThat = Workbooks.Open(latestFile)
Set wsThat = wbThat.Sheets("Ratesheet")
wsThat.Range(A7).Copy wsThis.Range("A7")
End Sub
Objective:
To save specific worksheets in a workbook as unique CSV files
Conditions:
To save specific worksheets (plural) from a workbook that contains both the specific worksheets and extraneous worksheets (e.g. to save specific 10 out of 20 available worksheets)
Insert the current date into the CSV's file name in order to avoid overwriting files currently in the save folder (this VBA is run daily)
File name syntax: CurrentDate_WorksheetName.csv
I've found VBA code that gets me half way to my goal. It saves ALL worksheets in the workbook but the file name is not dynamic with the current date.
Current Code:
Private Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
Dim DateToday As Range
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
' Store current details for the workbook
SaveToDirectory = "S:\test\"
For Each WS In ThisWorkbook.Worksheets
Sheets(WS.Name).Copy
ActiveWorkbook.SaveAs Filename:=SaveToDirectory & 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
There are several issues with your code:
i) There is no reason to save the format or name of your current workbook. Just use a new workbook to save the CSVs that you want.
ii) You were copying each worksheet in the book, but not copying it anywhere. This code was actually saving the same workbook with the name of each sheet. Copying the worksheet doesn't paste it anywhere and doesn't actually tell the saving function only to use parts of the document.
iii) To put the date in the name, you just need to append it to the save name string, as below.
Dim myWorksheets() As String 'Array to hold worksheet names to copy
Dim newWB As Workbook
Dim CurrWB As Workbook
Dim i As Integer
Set CurrWB = ThisWorkbook
SaveToDirectory = "S:\test\"
myWorksheets = Split("SheetName1, SheetName2, SheetName3", ",")
'this contains an array of the sheets.
'If you want more, put another comma and then the next sheet name.
'You need to put the real sheet names here.
For i = LBound(myWorksheets) To UBound(myWorksheets) 'Go through entire array
Set newWB = Workbooks.Add 'Create new workbook
CurrWB.Sheets(Trim(myWorksheets(i))).Copy Before:=newWB.Sheets(1)
'Copy worksheet to new workbook
newWB.SaveAs Filename:=SaveToDirectory & Format(Date, "yyyymmdd") & myWorksheets(i), FileFormat:=xlCSV
'Save new workbook in csv format to requested directory including date.
newWB.Close saveChanges:=False
'Close new workbook without saving (it is already saved)
Next i
CurrWB.Save 'save original workbook.
End Sub
It seems to me that in that code was a lot of unnecessary stuff but the most important part was almost ready.
Try this:
Sub SaveWorksheetsAsCsv()
Dim WS As Worksheet
Dim SaveToDirectory As String
SaveToDirectory = "C:\tmp\"
Application.DisplayAlerts = False
For Each WS In ThisWorkbook.Worksheets
WS.SaveAs Filename:=SaveToDirectory & Format(Now(), "yyyymmdd") & "_" & WS.Name & ".csv", FileFormat:=xlCSV
Next
Application.DisplayAlerts = True
End Sub
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
This question already has answers here:
Export each sheet to a separate csv file
(2 answers)
Closed 8 years ago.
I am very new with VB coding, I am trying to save multiple excel file worksheets to csv, I don't know to do this for multiple sheets, but I found a way to do for single file. I have found code on this site which are very useful for what I am trying to do, only problem is the files are saved with the worksheet name but I am trying to save them with the original file and worksheet name such as filename_worksheet name, I tried to do that myself but keep getting error, could you please advise what I am doing wrong?
The code I am using is as follows:
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 = "H:\test\"
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
I think this is what you want...
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 Application.ActiveWorkbook.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
I had a similar problem. Data in a worksheet I needed to save as a separate CSV file.
Here's my code behind a command button
Private Sub cmdSave()
Dim sFileName As String
Dim WB As Workbook
Application.DisplayAlerts = False
sFileName = "MyFileName.csv"
'Copy the contents of required sheet ready to paste into the new CSV
Sheets(1).Range("A1:T85").Copy 'Define your own range
'Open a new XLS workbook, save it as the file name
Set WB = Workbooks.Add
With WB
.Title = "MyTitle"
.Subject = "MySubject"
.Sheets(1).Select
ActiveSheet.Paste
.SaveAs "MyDirectory\" & sFileName, xlCSV
.Close
End With
Application.DisplayAlerts = True
End Sub
This works for me :-)
Is this what you are trying?
Option Explicit
Public Sub SaveWorksheetsAsCsv()
Dim WS As Worksheet
Dim SaveToDirectory As String, newName As String
SaveToDirectory = "H:\test\"
For Each WS In ThisWorkbook.Worksheets
newName = GetBookName(ThisWorkbook.Name) & "_" & WS.Name
WS.Copy
ActiveWorkbook.SaveAs SaveToDirectory & newName, xlCSV
ActiveWorkbook.Close Savechanges:=False
Next
End Sub
Function GetBookName(strwb As String) As String
GetBookName = Left(strwb, (InStrRev(strwb, ".", -1, vbTextCompare) - 1))
End Function
Best way to find out is to record the macro and perform the exact steps and see what VBA code it generates. you can then go and replace the bits you want to make generic (i.e. file names and stuff)
The code above works perfectly with one minor flaw; the resulting file is not saved with a .csv extension. – Tensigh 2 days ago
I added the following to code and it saved my file as a csv. Thanks for this bit of code.It all worked as expected.
ActiveWorkbook.SaveAs Filename:=SaveToDirectory & ThisWorkbook.Name & "-" & WS.Name & ".csv", FileFormat:=xlCSV