I want to save the active workbook as xlsx and then close it without closing all the open excel workbooks. This code works but closes all the open excel files.
If I remove Application.Quit and leave ThisWorkbook.Close it will work only if I have more then one workbook open but if I only have the one workbook open it will close but leave a blank excel window open.
Sub SaveAsXlsx()
Dim varResponse As Variant
varResponse = MsgBox("Save As xlsx Removing Macros & Then Closes The Workbook", vbYesNo, "Save As xlsx")
If varResponse <> vbYes Then Exit Sub
Application.DisplayAlerts = False
Dim FilePath As String
FilePath = ThisWorkbook.FullName
FilePath = Left(FilePath, Len(FilePath) - 5) & " To Review" & ".xlsx"
ThisWorkbook.SaveAs Filename:=FilePath, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
'Enter Anything to Happen on xlsx Book Here
Range("A1").Select
ThisWorkbook.Save
FilePath = Application.ActiveWorkbook.FullName
MsgBox "Saved Review Copy As" & Chr(10) & Chr(10) & FilePath, , "Saved!"
Application.Quit
ThisWorkbook.Close
End Sub
In order to close Excel if your code is closing the last open workbook, but leave it open if there are other workbooks open, you'll need to check the Application.Workbook.Count property, like this:
Sub SaveAsXlsx()
Dim varResponse As Variant
varResponse = MsgBox("Save As xlsx Removing Macros & Then Closes The Workbook", vbYesNo, "Save As xlsx")
If varResponse <> vbYes Then Exit Sub
Application.DisplayAlerts = False
Dim FilePath As String
FilePath = ThisWorkbook.FullName
FilePath = Left(FilePath, Len(FilePath) - 5) & " To Review" & ".xlsx"
ThisWorkbook.SaveAs Filename:=FilePath, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
'Enter Anything to Happen on xlsx Book Here
Range("A1").Select
ThisWorkbook.Save
FilePath = Application.ActiveWorkbook.FullName
MsgBox "Saved Review Copy As" & Chr(10) & Chr(10) & FilePath, , "Saved!"
ThisWorkbook.Close
If Excel.Application.Workbooks.Count = 0 Then
Application.Quit
End If
End Sub
Related
I wrote code that saves the book in a specific format. After saving, the book is only available in read-only mode. What could be the error?
Sub SaveAs()
Application.DisplayAlerts = False
Dim relativePath As String
relativePath = ThisWorkbook.Path & "\" & ActiveWorkbook.Name
ActiveWorkbook.SaveAs Filename:=relativePath, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False, ReadOnlyRecommended:=False, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
Application.DisplayAlerts = True
End Sub
My goal is to open multiple excel files from input folder and convert them to .csv in output folder. I am facing minor issues where
code converts .xlsx to .csv , converts .xls to .csv but in output
folder, it stores .csv and .xls files. I can't figure out why .xls
files are also getting stored. I only wish to store .csv files
I only want to convert data from excel 'Sheet1' but the code is
converting data from an active sheet. How to specify to convert
data only from 'Sheet1'?
Option Explicit
Sub ImportMultipleCsvFile()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Dim InputCsvFile As Variant
Dim InputFolder As String, OutputFolder As String
InputFolder = "C:\Users\excel_format"
OutputFolder = "C:\Users\csv_format"
InputCsvFile = Dir(InputFolder & "\*.xl??")
While InputCsvFile <> ""
Workbooks.OpenText Filename:=InputFolder & "\" & InputCsvFile, DataType:=xlDelimited, Comma:=True
ActiveWorkbook.SaveAs Filename:=OutputFolder & "\" & Replace(ActiveWorkbook.Name, ".xlsx", ".csv"), FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.SaveAs Filename:=OutputFolder & "\" & Replace(ActiveWorkbook.Name, ".xls", ".csv"), FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
InputCsvFile = Dir
Wend
Application.Calculation = xlCalculationAutomatic
End Sub
If you change this:
ActiveWorkbook.SaveAs Filename:=OutputFolder & "\" & Replace(ActiveWorkbook.Name, ".xlsx", ".csv"), FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.SaveAs Filename:=OutputFolder & "\" & Replace(ActiveWorkbook.Name, ".xls", ".csv"), FileFormat:=xlCSV, CreateBackup:=False
to that:
--- to remove VBA codeblocks from Workbook before saving them as .csv, I have used this stackoverflow answer, then I checked it to make sense by using the info from here ---
Dim StartWb As Workbook
Dim TempWb As Workbook
Set StartWb = ActiveWorkbook
Set TempWb = Application.Workbooks.Add
StartWb.Worksheets("Sheet1").Copy Before:=TempWb.Worksheets(1)
If TempWb.Worksheets.Count > 1 Then
Do While (TempWb.Worksheets.Count > 1)
TempWb.Worksheets(TempWb.Worksheets.Count).Delete
Loop
End If
' ----- This is new to delete the codeblocks from your Sheets -----------
Dim Element As Object
For Each Element In TempWb.VBProject.VBComponents
'For Each Item In Element.Collection ' This For loop wasn't needed at the and but I forgot it in
Element.CodeModule.DeleteLines 1, Element.CodeModule.CountOfLines
'Next ' It has most likely thrown up Undeclared Variable error with Option Eplicit
Next
' -----------------------------------------------------------------------
If InStr(StartWb.Name, ".xlsx") Then
TempWb.SaveAs Filename:=OutputFolder & "\" & Replace(StartWb.Name, ".xlsx", ".csv"), FileFormat:=xlCSV, CreateBackup:=False
ElseIf InStr(StartWb.Name, ".xls") Then
TempWb.SaveAs Filename:=OutputFolder & "\" & Replace(StartWb.Name, ".xls", ".csv"), FileFormat:=xlCSV, CreateBackup:=False
End If
TempWb.Close (xlNo)
then you will only get your .csv file saved, as well as it will only contain that first sheet.
I would also put these:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
at the end of your code before or after:
Application.Calculation = xlCalculationAutomatic
Also swap this:
ActiveWorkbook.Close
to that:
StartWb.Close (xlNo)
To remove code from workbooks by code you have to change settings in Excel:
i have created a macro to save a sheet to a specific location (see below):
Sub Savefileas()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Unprotect Password:="Spiralbevel1"
ws.EnableSelection = xlNoSelection
ws.Protect Password:="Spiralbevel1", DrawingObjects:=False, Contents:=True, Scenarios:=True
Next ws
Dim ThisFile As String
Dim varResult As Variant
ThisFile = Range("B4").Value
varResult = Application.GetSaveAsFilename(FileFilter:= _
"Macro Enabled Workbook" & "(*.xlsm), *xlsm", Title:=ThisFile & ".xlsm", InitialFileName:="G:\New Manufacturing Engineering\Gear Shop\Spiral Bevel\Miscellaneous\Stock Removal Test File\Stock Removals with Errors\ " & ThisFile & ".xlsm")
With ActiveWorkbook
On Error GoTo message
.SaveAs varResult & ".xlsm", FileFormat:=52
Exit Sub
message:
MsgBox "There is an error"
End With
End Sub
This sheet needs to be reviewed and then saved to a different location using this macro:
Sub Savefileas()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Unprotect Password:="Spiralbevel1"
ws.EnableSelection = xlNoSelection
ws.Protect Password:="Spiralbevel1", DrawingObjects:=True, Contents:=True, Scenarios:=True
Next ws
Dim ThisFile As String
Dim varResult As Variant
ThisFolder = Range("B2").Value
ThisFile = Range("B4").Value
varResult = Application.GetSaveAsFilename(FileFilter:= _
"Macro Enabled Workbook" & "(*.xlsm), *xlsm", Title:=ThisFolder & ThisFile & ".xlsm", InitialFileName:="G:\New Manufacturing Engineering\Gear Shop\Spiral Bevel\Miscellaneous\Stock Removal Test File\" & ThisFolder & "\ " & ThisFile & ".xlsm")
With ActiveWorkbook
On Error GoTo message
.SaveAs varResult & ".xlsm", FileFormat:=52
Exit Sub
message:
MsgBox "There is an error"
End With
End Sub
What i need to happen is the original file is deleted from the original folder is was saved to
Thanks in advance
When I use the following code to:
save a macro-enabled workbook
in the same folder as the open workbook
it does save the file with the wrong name and on the desktop:
Sub Save_New_MacroEnabledFile()
Dim thisWb As Workbook
Set thisWb = ActiveWorkbook
Worksheets("Sheet_with_VBA_Button").Activate
ActiveWorkbook.SaveAs Filename:=thisWb.Path & Sheets("Sheet_with_NewFile's_Name").Range("A2"), FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, Password:=vbNullString, WriteResPassword:=vbNullString, _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub
What am I doing wrong?
You didn't add slash when you creating new filepath.
Probably the folder where you have this file is on the desktop and without slash it just append the name of the file to the name of the folder, i.e.
folder was:
C:\Users\Antoine\Desktop\Folder
and after appending the filename without slash it was like:
C:\Users\Antoine\Desktop\Folderfilename.xlsx
Try this code:
Sub Save_New_MacroEnabledFile()
Dim thisWb As Workbook
Dim fileName As String
Set thisWb = ActiveWorkbook
Worksheets("Sheet_with_VBA_Button").Activate
Application.DisplayAlerts = False
fileName = thisWb.Path & "\" & Sheets("Sheet_with_NewFile's_Name").Range("A2") & VBA.IIf(Right(fileName, 5) = ".xlsm", "", ".xlsm")
ActiveWorkbook.SaveAs fileName:=fileName, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:=vbNullString, WriteResPassword:=vbNullString, _
ReadOnlyRecommended:=False, CreateBackup:=False
Application.DisplayAlerts = True
End Sub
I'm using the code below so users can "export" the Workbook they're working on. Basically, they're working in a Read-only master workbook, when they click the sub below it executes a SaveAs to a folder the user selects with the file name of whatever is in: Sheets("Master").Range("B5")
This works fine, the only problem is that if there's a '.xlsm' file in the folder the user selects and they click it to grab the filename, the saved Workbook name becomes "XXXXXX.xlsm.xlsm". If the user doesn't click anything and hits save it works fine.
Any ideas? Let me know if this wasn't clear
Sub ExportTrip()
Dim ActSheet As Worksheet
Dim ActBook As Workbook
Dim CurrentFile As String
Dim NewFile As String
Application.ScreenUpdating = False ' Prevents screen refreshing.
CurrentFile = ThisWorkbook.FullName
NewFile = Application.GetSaveAsFilename( _
InitialFileName:=Sheets("Master").Range("B5"))
If NewFile <> "" And NewFile <> "False" Then
ActiveWorkbook.SaveAs filename:=NewFile & "xlsm", _
FileFormat:=52, _
Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False
Set ActBook = ActiveWorkbook
Workbooks.Open CurrentFile
Application.DisplayAlerts = False
ActBook.Close
Application.DisplayAlerts = True
End If
Application.ScreenUpdating = True
End Sub
Figured it out, needed to add file filter. See below:
Sub ExportTrip()
Dim ActSheet As Worksheet
Dim ActBook As Workbook
Dim CurrentFile As String
Dim NewFile As String
Application.ScreenUpdating = False ' Prevents screen refreshing.
CurrentFile = ThisWorkbook.FullName ' saves filename of current workbook
NewFile = Application.GetSaveAsFilename( _
InitialFileName:=Sheets("Master").Range("B5"), _
FileFilter:="ARMS Export *.xlsm (*.xlsm),") ' gets filename for exported workbook
If NewFile <> "" And NewFile <> "False" Then 'if user doesn't pick name
ActiveWorkbook.SaveAs filename:=NewFile, _
FileFormat:=52, _
Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False
Set ActBook = ActiveWorkbook 'declares variable for open workbook
Workbooks.Open CurrentFile 'reopens original workbook
Application.DisplayAlerts = False
ActBook.Close 'closes exported workbook
Application.DisplayAlerts = True
End If
Application.ScreenUpdating = True
End Sub