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.
Related
I have a requirement to open an existing file from a different location and save each worksheet into different csv files in the name of the worksheet name (tab name).
Sub SplitFile()
Dim vPath As String
vPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=vPath & "\" & xWs.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This works for the currently active workbook but I would like to process another workbook in a particular path.
I tried to assign a variable which holds the file path but it is throwing an error.
You need to create a workbook variable and assign a workbook object to it:
Sub SplitFile()
Dim vPath As String
Dim wb As Workbook
Dim wbPath As Variant
wbPath = Application.GetOpenFileName("Excel Files (*.xls*), *.xls*")
If wbPath = False Then Exit Sub
Set wb = Workbooks.Open(wbPath)
vPath = wb.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In wb.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=vPath & "\" & xWs.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
As you can see, once you've assigned your workbook you just refer to that in your code wherever needed.
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
I want to cycle through all workbooks in a folder, extract worksheets named "Sheet Name", and save them as .csv files with the name of the file from which they originated. What's quick way to do this?
Example of vba function in question:
Sub Sheet_SaveAs()
Dim wb As Workbook
Sheets("Sheet Name").Copy
Set wb = ActiveWorkbook
With wb
.SaveAs ThisWorkbook.Path & "\" & ThisWorkbook.name, FileFormat:=xlCSV
'.Close False
End With
End Sub
Many thanks for looking
EDIT: Not a duplicate because I am working on extracting sheets from multiple workbooks, and not multiple worksheets from a single workbook.
EDIT2: thank you, everyone.
Something like this.
Change this path to suit your folder
strFolder = "c:\temp"
code
Sub LoopThroughFiles()
Dim Wb As Workbook
Dim ws As Worksheet
Dim strFolder As String
Dim strFile As String
strFolder = "c:\temp"
strFile = Dir(strFolder & "\*.xls*")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Do While Len(strFile) > 0
Set Wb = Workbooks.Open(strFolder & "\" & strFile)
Set ws = Nothing
On Error Resume Next
Set ws = Wb.Sheets("Sheet Name")
On Error GoTo 0
If Not ws Is Nothing Then ws.SaveAs Left$(Wb.FullName, InStrRev(Wb.FullName, ".")) & "csv", FileFormat:=xlCSV
Wb.Close False
strFile = Dir
Loop
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
I have a macro written that take a range from one workbook and copies into into a new workbook, which then saves the newly created workbook (and gives it a name) into the same folder path. When this workbook already exists, (overwriting the workbook), the default windows dialogue box pops up asking if you would like to overwrite, with a yes no cancel selection of buttons. When the cancel button is pressed, a new workbook is created. How do I edit this code so that when cancel is pressed, no new workbook is created? I have pasted the macro below:
Sub ExportNewBook()
Application.ScreenUpdating = False
Dim ThisWB As Workbook
Set ThisWB = ActiveWorkbook
Set NewBook = Workbooks.Add
On Error Resume Next
ThisWorkbook.Worksheets("Summary").Range("A1:I100").Copy
NewBook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteValues)
NewBook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteFormats)
NewBook.Worksheets("Sheet1").Range("A:J").Columns.AutoFit
NewBook.SaveAs Filename:=ThisWB.Path & "\" & NewBook.Worksheets("Sheet1").Range("A4").Value & "_Summary"
NewBook.ActiveSheet.Range("A1").Select
Application.ScreenUpdating = True
End Sub
EDIT: WORKING CODE SHOWN BELOW
Sub ExportNewBook()
Application.ScreenUpdating = False
Dim ThisWB As Workbook
Dim fname As String
Set ThisWB = ActiveWorkbook
Set Newbook = Workbooks.Add
ThisWorkbook.Worksheets("Summary").Range("A1:I100").Copy
Newbook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteValues)
Newbook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteFormats)
Newbook.Worksheets("Sheet1").Range("A:J").Columns.AutoFit
fname = ThisWB.Path & "\" & ThisWB.Worksheets("Summary").Range("A4").Value & "_Summary.xls"
If Dir(fname) <> "" Then
If MsgBox("Summary output already exists, are you sure you want to overwrite?", vbOKCancel) = vbCancel Then Newbook.Close False: Application.CutCopyMode = False: Exit Sub
End If
Application.DisplayAlerts = False
Newbook.SaveAs Filename:=fname
Application.DisplayAlerts = True
ThisWB.Activate
ActiveWorkbook.Worksheets("Summary").Range("A1").Select
Newbook.Activate
ActiveWorkbook.ActiveSheet.Range("A1").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Thank you!
On error resume next is seldom a good idea. If the user selects no or cancel, an error is triggered. Better to handle that error to delete the unwanted workbook (although another idea is to test if a workbook with the target name exists before creating it and, if it does, use msgbox to ask the user if they want to overwrite the file and, if so, only then create the workbook, disable alerts, and only then do saveas).
A problem seems to be that you need to have a filename to kill a workbook. In your situation the workbook doesn't yet have a filename. One solution is to create a safe filename whose sole purpose in life is to kill an unwanted workbook, do saveas again with this name, then kill it. Something like this:
Sub Test()
On Error GoTo err_handler
Dim wb As Workbook
Dim fname As String
Dim tempname As String
fname = "C:\Programs\testbook.xlsx"
Set wb = Workbooks.Add
wb.Sheets(1).Range("A1").Value = Now 'for testing purposes
wb.SaveAs fname
Exit Sub
err_handler:
tempname = "C:\Programs\name_i_will_never_use.xlsx"
wb.SaveAs tempname
wb.Close
Kill tempname
End Sub
Here is a possible approach:
Sub ExportNewBook()
Application.ScreenUpdating = False
Dim ThisWB As Workbook, Newbook As Workbook
Dim fname As String
Set ThisWB = ActiveWorkbook
fname = ThisWB.Path & "\" & ThisWB.Sheets("Sheet1").Range("A4").Value & "_Summary"
If Dir(fname) <> "" Then
If MsgBox("Are you sure you want to overwrite?", vbOKCancel) = vbCancel Then Exit Sub
End If
Set Newbook = Workbooks.Add
ThisWB.Worksheets("Summary").Range("A1:I100").Copy
Newbook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteValues)
Newbook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteFormats)
Newbook.Worksheets("Sheet1").Range("A:J").Columns.AutoFit
'This code should be faster since it bypasses the copy-paste buffer
'With Newbook.Sheets(1)
' ThisWB.Sheets("Summary").Range("A1:I100").Copy .Range("A1")
' .Range("A1:I100").Value = .Range("A1:I100").Value
' .Columns.AutoFit
'End With
Application.DisplayAlerts = False
Newbook.SaveAs Filename:=fname
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
this is the full code with
check if file already exist
if exist close the newbook and ask you if the existed file will be opened
close the newbook
in case of error save the newbook with (error) suffix before the extension file
Sub ExportNewBook()
Application.ScreenUpdating = False
Dim ThisWB As Workbook
Dim NewName As String
Set ThisWB = ActiveWorkbook
Set NewBook = Workbooks.Add
On Error GoTo err_handler
ThisWB.Worksheets("Summary").Range("A1:I100").Copy
NewBook.Worksheets("Foglio1").Range("A1").PasteSpecial (xlPasteValues)
NewBook.Worksheets("Foglio1").Range("A1").PasteSpecial (xlPasteFormats)
NewBook.Worksheets("Foglio1").Range("A:J").Columns.AutoFit
NewName = ThisWB.Path & "\" & NewBook.Worksheets("Foglio1").Range("A4").Value & "_Summary.xls"
If Dir(NewName) "" Then
If MsgBox("A file named '" & NewName & " already exists." & vbCr & vbCr & _
MeaName & " will now open??", vbYesNo) = vbYes Then
Workbooks.Open NewName
End If
NewBook.Close False
Exit Sub
End If
NewBook.SaveAs Filename:=NewName
NewBook.ActiveSheet.Range("A1").Select
NewBook.Close
Application.ScreenUpdating = True
err_handler:
NewName = ThisWB.Path & "\" & NewBook.Worksheets("Foglio1").Range("A4").Value & "_Summary(error).xls"
NewBook.SaveAs Filename:=NewName
NewBook.ActiveSheet.Range("A1").Select
NewBook.Close
Application.ScreenUpdating = True
End Sub
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