VBA code creating false.xml files - excel

I use the code below to save a workbook using two fields as the name. This part works dead on but when the save as window opens and i click cancel, it creates a false.xml excel file. Not sure as to why. I have tried using without the if statement but still creates it.
Can someone tell me why this happens and how to stop it?
Also is there code to catch errors in vb?
Regards
Sub FileSave()
Dim IntialName As String
Dim fileSaveName As Variant
InitialName = Range("C2") & " " & Range("H2") & " Cash Sheet"
fileSaveName = Application.GetSaveAsFilename(InitialFileName:=InitialName, _
fileFilter:="Excel Files (*.xls), *.xls")
If fileSaveName <> False Then
MsgBox "Save as " & fileSaveName
End If
ActiveWorkbook.SaveAs fileSaveName
End Sub

In your code you check for If fileSaveName <> False but if it is false you save the workbook in spite. So VBA builds an filename from this False value. Write
If fileSaveName <> False Then
MsgBox "Save as " & fileSaveName
ActiveWorkbook.SaveAs fileSaveName
End If
instead.
For error handling in VBA look here.

Related

Limit Excel file to save only as macro enabled (.xlsm or .xlmt) by using VBA

I am trying to use the code below to limit both save and save as to save file with macros. Code is placed in "ThisWorkbook".
My main goal is to create a template with macros for other to use, but when they open the template the often forget to save it with macros because the default setting is .xlsx format.
The excel template is placed in Sharepoint as read only for all. People when then save a copy in their own folder either on sharepoint or a server.
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
' Declare variables.
Dim FileName As String
Dim FileLocation As String
' Check if the Save As command is being used.
If SaveAsUI = True Then
' Create a FileDialog object.
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogSaveAs)
' Set the file filter.
fd.FilterIndex = 2
fd.Filters.Clear
fd.Filters.Add "Excel Macro-Enabled Workbook", "*.xlsm"
fd.Filters.Add "Excel Macro-Enabled Template", "*.xltm"
' Display the file dialog box.
If fd.Show = -1 Then
FileName = fd.SelectedItems(1)
Else
Cancel = True
Exit Sub
End If
' Save the workbook or template with macros.
Application.DisplayAlerts = False
If Right(FileName, 5) = ".xlsm" Then
ActiveWorkbook.SaveAs Filename:=FileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Else
ActiveWorkbook.SaveAs Filename:=FileName, FileFormat:=xlOpenXMLTemplateMacroEnabled
End If
Application.DisplayAlerts = True
Cancel = True
End If
End Sub
But I get this error when saving:
Screenshot for last comment:
As I wrote in my above comment, `FileDialog(msoFileDialogSaveAs)' does not accept filters. So, everything related to filters will raise errors. Please, use the next way, instead:
Sub testSaveAsFilename()
Dim fileSaveName As String, fileName As String
fileName = left(ThisWorkbook.name, InStrRev(ThisWorkbook.name, ".") - 1): Stop
fileSaveName = Application.GetSaveAsFilename(InitialFileName:=fileName, _
FileFilter:="Excel Macro-Enabled Workbook (*.xlsm)," & "*.xlsm, Excel Macro-Enabled Template " & _
"Workbook (*.xlst), *xlst", Title:="Save AS MACRO ENABLED:")
Debug.Print fileSaveName
End Sub
I did not implement it in your code, but it should be something extremely simple, I think...
And I would also like to suggest to use only *.xlsm as filter. Do you want them keeping the template on their own computer? I think it may be a spring of problems... I mean, if you modify the template and they keep using the saved once. In order to make the code letting you save it as template you can add the second filter conditioned by your user name.
In fact, such a version will look as:
Sub testSaveAsFilenameOnlyXlsm()
Dim fileSaveName As String, fileName As String, filt As String
fileName = left(ThisWorkbook.name, InStrRev(ThisWorkbook.name, ".") - 1)
If Application.userName = "your user name" Then
filt = "Excel Macro-Enabled Workbook (*.xlsm)," & "*.xlsm, Excel Macro-Enabled Template " & _
"Workbook (*.xlst), *xlst"
Else
filt = "Excel Macro-Enabled Workbook (*.xlsm)," & "*.xlsm"
End If
fileSaveName = Application.GetSaveAsFilename(InitialFileName:=fileName, _
FileFilter:=filt, Title:="Save AS MACRO ENABLED:")
Debug.Print fileSaveName
End Sub
You may encrypt your user name and place it in a variable, to not be so clear for all not skilled (in VBA) users...
Re Edited:
The above code implemented in your code event:
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim fileSaveName As String, FileName As String, filt As String, posDot As Long
Const yourUserName As String = "your real user name" 'addapt it, please
' Check if the Save As command is being used.
If SaveAsUI = True Then
posDot = InStrRev(ThisWorkbook.Name, ".") 'check if a dot exists in the name (to separate extension)
If posDot > 0 Then
FileName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
Else
FileName = ThisWorkbook.Name
End If
If Application.UserName = "Fane Branesti" Then 'for your user name to also allow xltm extension:
filt = "Excel Macro-Enabled Workbook (*.xlsm)," & "*.xlsm, Excel Macro-Enabled Template " & _
"Workbook (*.xltm), *xltm"
Else
filt = "Excel Macro-Enabled Workbook (*.xlsm)," & "*.xlsm"
End If
fileSaveName = Application.GetSaveAsFilename(InitialFileName:=FileName, _
FileFilter:=filt, Title:="Save AS MACRO ENABLED:")
If fileSaveName = "False" Then Cancel = True: Exit Sub
Application.EnableEvents = False 'disable events after SaveAs
If Right(fileSaveName, 5) = ".xlsm" Then
ActiveWorkbook.SaveAs FileName:=fileSaveName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Else
ActiveWorkbook.SaveAs FileName:=fileSaveName, FileFormat:=xlOpenXMLTemplateMacroEnabled
End If
Application.EnableEvents = True 'reenable events
Cancel = True 'stop saving in the standard way
End If
End Sub

Open file folder to specific location through VBA [duplicate]

Using 2010 Excel VBA - I'm just trying to open a folder through a sub. What am I doing wrong here?
VBA
Sub openFolder()
Dim preFolder As String, theFolder As String, fullPath as String
theFolder = Left(Range("T12").Value, 8)
preFolder = Left(Range("T12").Value, 5) & "xxx"
fullPath = "P:\Engineering\031 Electronic Job Folders\" & preFolder & "\" & theFolder
Shell(theFolder, "P:\Engineering\031 Electronic Job Folders\" & preFolder, vbNormalFocus)
End Sub
If you want to open a windows file explorer, you should call explorer.exe
Call Shell("explorer.exe" & " " & "P:\Engineering", vbNormalFocus)
Equivalent syxntax
Shell "explorer.exe" & " " & "P:\Engineering", vbNormalFocus
I use this to open a workbook and then copy that workbook's data to the template.
Private Sub CommandButton24_Click()
Set Template = ActiveWorkbook
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = "I:\Group - Finance" ' Yu can select any folder you want
.Filters.Clear
.Title = "Your Title"
If Not .Show Then
MsgBox "No file selected.": Exit Sub
End If
Workbooks.OpenText .SelectedItems(1)
'The below is to copy the file into a new sheet in the workbook and paste those values in sheet 1
Set myfile = ActiveWorkbook
ActiveWorkbook.Sheets(1).Copy after:=ThisWorkbook.Sheets(1)
myfile.Close
Template.Activate
ActiveSheet.Cells.Select
Selection.Copy
Sheets("Sheet1").Select
Cells.Select
ActiveSheet.Paste
End With

How to save xlsm as xlsx?

I have a xslm file. I want to save the file as xlsx and email.
I am able to SaveCopyAs it as xls file. If I try to save it as xlsx, it does get saved but when I open it, it gives an error.
ActiveWorkbook.SaveCopyAs Filename:=ActiveWorkbook.Path & "\MyFileName - " & Format(Date, "mm-dd-yyyy") & ".xlsx"
Excel cannot open the file '...path\MyFileName.xlsx' because the file format or file extension is not valid. Verify that file has not been corrupted and that file extension matches the format of the file
SaveCopyAs does not change the file-type.
You simply cannot save a .xlsm as .xlsx via SaveCopyAs.
EDIT
a workaround is to save a copy which then is changed in type while the old copy will be deleted like:
Dim wb As Workbook, pstr As String
pstr = ActiveWorkbook.Path & "\MyFileName - " & Format(Date, "mm-dd-yyyy") & ".xlsm"
ActiveWorkbook.SaveCopyAs Filename:=y
Set wb = Workbooks.Open(pstr)
wb.SaveAs Left(pstr, Len(pstr) - 1) & "x", 52
wb.Close False
Kill pstr
Try this:
Sub SaveAsXLSX()
ThisWorkbook.Save 'Optional
Application.DisplayAlerts = False
ThisWorkbook.SaveAs ActiveWorkbook.Path & "\MyFileName - " & Format(Date, "mm-dd-yyyy"), 51 '51 = xlsx
Application.DisplayAlerts = True
ThisWorkbook.Close 'Optional
End Sub
All you need to do is SaveAs and change the file format to 51 (xlsx)
If you want to "Save a copy" - SaveAs does practically the same thing - the difference being your currently open file becomes the saved file, but you can simply reopen the old one if you wish and nothing changes.
What you actually want to do is SaveAs a different file type, so use SaveAs.
I This is more readable. TESTED.
Sub SaveXlsmAsXlsx()
Dim wb As Workbook, Filenamepath As String, Filenameext As String, Filenameonly As String, Filepathonly As String
Application.DisplayAlerts = False
Filenamepath = ActiveWorkbook.FullName
Filenameext = ActiveWorkbook.Name
Filenameonly = Replace(Filenameext, ".xlsm", "")
Filepathonly = Replace(Filenamepath, ".xlsm", "")
Set wb = Workbooks.Open(Filenamepath)
'51 = xlsx
wb.SaveAs Filename:=Filepathonly & "_" & Format(Date, "mm-dd-yyyy"), FileFormat:=51
wb.Close True
'Kill- Best not to kill anyone, you might be sorry
ThisWorkbook.Close SaveChanges:=True
Application.DisplayAlerts = True
End Sub
This code add to any module:
Public Sub XLSMtoXLSX(FaylAdi As String)
Dim FullPath As String
Dim wb As Workbook
MsgBox "YOU WILL GET A WARNING AFTER COMPLETED, PLEASE WAIT"
ThisWorkbook.Save
On Error GoTo XETA
'You can change the name of the folder path below
FullPath = "C:\kohne sistem\Excel\VBA\Anbar\temp\" & FaylAdi & ".xlsm"
ThisWorkbook.SaveCopyAs FullPath
Application.DisplayAlerts = False
Set wb = Workbooks.Open(FullPath)
wb.SaveAs Left(FullPath, Len(FullPath) - 1) & "x", 51
wb.Close False
Kill FullPath
Application.DisplayAlerts = True
MsgBox "COMPLETED CORRECTLY"
Exit Sub
XETA: MsgBox "THERE WAS A FAULT SOMEWHERE"
End Sub
Then you can use it like this:
Private Sub CommandButton1_Click()
Call XLSMtoXLSX(Date)
End Sub

Loop Freezing Excel After Printing

I have a spreadsheet that creates a CSV file and deposits the CSV file in a folder next to the original file. The spreadsheet seems to work fine. When you have your data entered, you click export, and a CSV file is put in a folder called "Uploads" that is next to the original file.
The issue is when I use the quick print button on my Excel quick access toolbar. When I click the quick print button, everything seems to print fine. However, as soon as I close the file, (EDIT: ALL Printing seems to be freezing the file. As soon as the file is closed) Excel then goes into a freeze where it looks like it is trying to run some code? I am a novice in VBA so I am not sure what is happening, all I know is that after my file is closed, Excel freezes up and I have to restart Excel. I do not even have any macros or VBA for an Excel close or Excel open trigger.
Can anyone recreate the issue and give me insight into how my code might be doing this?
Private Sub Export_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim MyPath As String
Dim MyFileName As String
'The path and file names:
MyPath = ActiveWorkbook.Path & "\Uploads"
MyFileName = "" & Range("a2") & "_Upload"
On Error GoTo Ending
'Makes sure the path name ends with "\":
If Not Right(MyPath, 1) = "\" Then MyPath = MyPath & "\"
'Makes sure the filename ends with ".csv"
If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
'Copies the sheet to a new workbook:
Sheets("UploadData").Copy
'The new workbook becomes Activeworkbook:
With ActiveWorkbook 'Saves the new workbook to given folder / filename:
.SaveAs FileName:= _
MyPath & MyFileName, _
FileFormat:=xlCSV, _
CreateBackup:=False 'Closes the file
.Close False
End With
ChDir MyPath
Workbooks.Open FileName:= _
MyPath & "\" & MyFileName & """"
ActiveWorkbook.Save
ActiveWorkbook.Close
GoTo Skip
Ending:
MsgBox ("ERROR! Please make sure you have a folder named Uploads next to the template file")
ActiveWorkbook.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Skip:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This actually shouldn't work at all, regardless of what you do before you run it. First, you ensure that MyPath ends with a \ here...
'Makes sure the path name ends with "\":
If Not Right(MyPath, 1) = "\" Then MyPath = MyPath & "\"
...but then when you (re)build the same path below you're inserting a second \:
Workbooks.Open FileName:= _
MyPath & "\" & MyFileName & """"
This should always fail. You can avoid this entire problem with paths by using the Scripting.FileSystemObject's .BuildPath function:
'Requires a reference to Microsoft Scripting Runtime.
Dim filePath As String, fso As New Scripting.FileSystemObject
filePath = fso.BuildPath(ThisWorkbook.Path, MyFileName)
You can also use this for the file extension:
If LCase$(fso.GetExtensionName(MyFileName)) <> "csv" Then
MyFileName = MyFileName & ".csv"
End If
Note that this test will never be true...
If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
...because MyFileName will always end with "load":
MyFileName = "" & Range("a2") & "_Upload"
Also, you should remove all the references to ActiveWorkbook. I have no idea why printing would effect this, but there isn't anything else I can identify that should be an issue. I'd structure it more like this (error handler removed for clarity - don't put it back until you're finished debugging it):
'Add a reference to Microsoft Scripting Runtime.
Private Sub Export_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With New Scripting.FileSystemObject
Dim filePath As String
Dim targetDir As String
targetDir = .BuildPath(ThisWorkbook.Path, "Uploads")
If Not .FolderExists(targetDir) Then
MsgBox ("ERROR! Please make sure you have a folder named Uploads next to the template file")
Exit Sub
End If
filePath = .BuildPath(targetDir, ActiveSheet.Range("A2").Value & "_Upload.csv")
End With
'Copies the sheet to a new workbook:
Dim csv As Workbook
Set csv = Application.Workbooks.Add
With csv
ThisWorkbook.Sheets("UploadData").Copy .Sheets(1)
.SaveAs Filename:=filePath, _
FileFormat:=xlCSV, _
CreateBackup:=False 'Closes the file
.Close xlDoNotSaveChanges
End With
'Reopen and re-save to fix formatting.
Set csv = Workbooks.Open(filePath)
csv.Close xlSaveChanges
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Runtime error 1004 document not saved with Vba Excel 2016

I am getting a Runtime error 1004 document not saved using vba when I want to save an Excel workbook in my folder on desktop. Here are the details of my code:
Private Sub Save_Click()
'Popup the Window "Save As"
Application.DisplayAlerts = False
MsgBox "Do not change the default file name proposed on the next step please !"
Dim fName As Variant
Dim DName As String ' Variable storing name of excel workbook which has to be saved
DName = UserForm.CustomerApplication.Value & " - " & UserForm.L2GType.Value
& " - " & UserForm.Title.Value & " - " & UserForm.Country.Value & "(" &
Year(Date) & ")"
fName = Application.GetSaveAsFilename(InitialFileName:=DName, _
FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Save As")
If fName = False Then
Exit Sub
ActiveWorkbook.SaveAs filename:=fName, FileFormat:=51
ActiveWorkbook.Close
End Sub
I think you are missing an 'End If' at the bottom of your code. The 'If fName = False Then...' part. Try the following
Private Sub Save_Click()
'Popup the Window "Save As"
Application.DisplayAlerts = False
MsgBox "Do not change the default file name proposed on the next step please !"
Dim fName As Variant
Dim DName As String ' Variable storing name of excel workbook which has to be saved
DName = UserForm.CustomerApplication.Value & " - " & UserForm.L2GType.Value
& " - " & UserForm.Title.Value & " - " & UserForm.Country.Value & "(" &
Year(Date) & ")"
fName = Application.GetSaveAsFilename(InitialFileName:=DName, _
FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Save As")
If fName = False Then
Exit Sub
End If
ActiveWorkbook.SaveAs filename:=fName, FileFormat:=51
ActiveWorkbook.Close
End Sub
fName is a String, therefore you can't compare it with False, but with "False".
Try replacing the last section of your code with the lines below:
fName = Application.GetSaveAsFilename(InitialFileName:=DName, _
fileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Save As")
If fName <> "False" Then
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=fName, FileFormat:=51
Else
MsgBox "No File was selected !"
Exit Sub
End If
Application.DisplayAlerts = True
Note: using FileFormat:=51, means xlOpenXMLWorkbook, an .xlsx format (without MACROs).
However since you want to use the SaveAs command with ThisWorkbook, which contains this code, you will get a prompt screen that asks if you want to save it as .xslx , which means all your code will be lost.
You can select FileFormat:=52, means xlOpenXMLWorkbookMacroEnabled, an .xlsm format (with MACROs).

Resources