Close workbook and finish VBA procedure in another workbook - excel

I use the following VBA to create a copy of the spreadsheet which is used:
Sub Files()
ActiveWorkbook.SaveCopyAs "C:\Users\" & Environ("Username") & "\Desktop\testfile.xlsm"
Workbooks.Open "C:\Users\" & Environ("Username") & "\Desktop\" & "testfile.xlsm", UpdateLinks:=False
ThisWorkbook.Close SaveChanges = False
MsgBox ("File saved successfully on desktop.")
End Sub
This code puts a copy of the Excel file on the desktop. Once this is done the new created Excel file is opened and the other one is closed. However, the closing of the other one causes the VBA to stop as well; therefore, the MsgBox ("File saved successfully on desktop.") does not appear anymore.
How do I have to change the VBA so it continues in the new opened spreadsheet and displays the message box?

ThisWorkbook.Close SaveChanges = False closes the workbook. The VBA code is inside, thus the MsgBox does not appear.
The easiest solution is to change a bit your code like this:
MsgBox ("File saved successfully on desktop.")
ThisWorkbook.Close SaveChanges = False
To make sure that your MsgBox does not "lie", introduce Error-capture:
Sub Files()
On Error GoTo Files_Error
ActiveWorkbook.SaveCopyAs "C:\Users\" & Environ("Username") & "\Desktop\testfile.xlsm"
Workbooks.Open "C:\Users\" & Environ("Username") & "\Desktop\" & "testfile.xlsm", UpdateLinks:=False
MsgBox ("File saved successfully on desktop.")
ThisWorkbook.Close SaveChanges = False
On Error GoTo 0
Exit Sub
Files_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Files of Sub Modul1"
End Sub
If the file cannot be saved after the MsgBox, a new MsgBox would pop-up.

Related

Why is Workbook.Open() triggered twice on Workbook.SaveAs

I just need my users to use the automatically saved copy of my file on their desktop when the file is located on SharePoint.
It looks like the Workbook.Open is triggered on SaveAs, as it execute the same code twice. I want it to close the SharePoint file - and reopen the new file from users desktop, but it seams to respond with the same path.
I have tried this in ThisWorkbook code:
`
Private Sub Workbook_Open()
MsgBox ThisWorkbook.Path
If Left(ThisWorkbook.Path, 2) <> "C:" Then
MsgBox "This workbook will now be saved on you desktop. Please use it from your desktop location."
ThisWorkbook.SaveAs Filename:="C:\Users\" & Environ$("Username") & _
"\Desktop\" & ThisWorkbook.Name, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled
ThisWorkbook.Close
End If
End Sub
`
When using SaveAs (correct me if I'm wrong) on ThisWorkbook, it'll get you straight in the newly created file, instead of making a copy of itself and saving it in the same path. That's at least how I understood it since the MsgBoxes weren't triggered so it wasn't like the Workbook_Open got triggered again.
My workaround to not have it continue the code on it as follows, however when their C is virtually on the sharepoint (as I figured out mine is), the "C:" check is automatically True since your path will be from the sharepoint onwards (I noticed this with the second commented MsgBox):
Private Sub Workbook_Open()
Dim cFileName As String, cFileExists As String
Dim wb As Workbook
' MsgBox ThisWorkbook.Path
' MsgBox Left(ThisWorkbook.Path, 2)
If Left(ThisWorkbook.Path, 2) <> "C:" Then 'put your full path of original file here
MsgBox "This workbook will now be saved on you desktop. Please use it from your desktop location."
cFileName = "C:\Users\" & Environ("Username") & "\Dekstop\" & ThisWorkbook.Name
cFileExists = Dir(cFileName)
If cFileExists = "" Then 'check if it exists already
Set wb = ActiveWorkbook
wb.SaveCopyAs cFileName
Else
MsgBox "This file already exists"
End If
ThisWorkbook.Close
End If
End Sub
This way you can't have it open after running the code however. What you can also try is:
https://stackoverflow.com/a/19846141/19353309
Edit:
Private Sub Workbook_Open()
Dim cFileName As String, cFileExists As String
Dim wb As Workbook
If InStr(1, ActiveWorkbook.Path, Environ("Username")) > 0 Then Exit Sub 'if it's not original file, exit sub immediately, just don't put this file in a path with your name in it :p
'I would have used "C:\Users\" & Environ("Username") but this did not work with my copy.Path being part of the sharepoint even when the file is saved on C:\
cFileName = "C:\Users\" & Environ("Username") & "\Desktop\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & " - " & Environ("Username") & ".xlsm" 'this way both files can be open (can't have two workbooks with the same name open)
Set wb = ActiveWorkbook
cFileExists = Dir(cFileName)
If cFileExists = "" Then 'copy does not exist yet
MsgBox "This workbook will now be saved on you desktop. Please use it from your desktop location."
wb.SaveCopyAs cFileName
Else 'copy exists
MsgBox ("File already exists, opening this version")
End If
Workbooks.Open Filename:=cFileName
wb.Close
End Sub

Create a new file and delete password protection

I use the following VBA to save a new file on my desktop:
Sub Files()
ActiveWorkbook.SaveCopyAs "C:\Users\" & Environ("Username") & "\Desktop\testfile.xlsm"
Workbooks.Open "C:\Users\" & Environ("Username") & "\Desktop\" & "testfile.xlsm", UpdateLinks:=False
MsgBox ("File saved successfully on desktop.")
ThisWorkbook.Close SaveChanges = False
End Sub
All this works fine so far.
My original file is proteced with a password. This protection should be deleted in the new file which is created using the VBA above.
For unprotecting the file I have the following VBA:
Sub Unprotection()
Dim b As Worksheet
For Each b In Worksheets
b.Unprotect Password:="abc"
Next b
End Sub
However, i do not know how to enter this code into the procedure of creating the new file. I tried to go with the below code but it only runs in the original file and not in the new file I have created.
Sub Files()
ActiveWorkbook.SaveCopyAs "C:\Users\" & Environ("Username") & "\Desktop\testfile.xlsm"
Workbooks.Open "C:\Users\" & Environ("Username") & "\Desktop\" & "testfile.xlsm", UpdateLinks:=False
Call Unprotection
MsgBox ("File saved successfully on desktop.")
ThisWorkbook.Close SaveChanges = False
End Sub
Do you have any idea how to solve this issue?
If you don't want to unprotect your original workbook you can pass the new workbook as a parameter to Unprotection:
Sub Files()
Dim wb As Workbook
ActiveWorkbook.SaveCopyAs "C:\Users\" & Environ("Username") & "\Desktop\testfile.xlsm"
Set wb = Workbooks.Open("C:\Users\" & Environ("Username") & "\Desktop\" & "testfile.xlsm", UpdateLinks:=False)
Call Unprotection(wb)
MsgBox ("File saved successfully on desktop.")
ThisWorkbook.Close SaveChanges = False
End Sub
Sub Unprotection(wb As Workbook)
Dim b As Worksheet
For Each b In wb.Worksheets
b.Unprotect Password:="abc"
Next b
End Sub
Quickest fix is to move Unprotection to the very start of your routine.
You don't need to reprotect because you close the calling workbook without saving the changes anyway.
Sub Files()
Call Unprotection ' unprotect calling workbook sheets
ActiveWorkbook.SaveCopyAs "C:\Users\" & Environ("Username") & "\Desktop\testfile.xlsm" ' save a copy with non-protected sheets
Workbooks.Open "C:\Users\" & Environ("Username") & "\Desktop\" & "testfile.xlsm", UpdateLinks:=False ' open the new non-protected book
MsgBox ("File saved successfully on desktop.") ' Message
ThisWorkbook.Close SaveChanges = False ' Close the calling workbook without saving the unprotected sheets
End Sub

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

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).

VBA .VBProject.VBComponents.Item("ThisWorkbook").CodeModule.AddFromString isn't working

I am creating a bunch of workbooks dynamically that are linked and I need to suppress the linked warning, so I am trying to add a Workbook_Open() sub with the proper code.
Only problem is that the code isn't actually being added to the workbook.
' do not display alerts while processing so many files
Application.DisplayAlerts = False
wbNew.SaveAs FileName:=path, FileFormat:=51, CreateBackup:=False
' add a little Workbook_Open method to the new workbook's ThisWorkbook dynamically
' this line doesn't actually do anything - why?
wbNew.VBProject.VBComponents.Item("ThisWorkbook").CodeModule.AddFromString ( _
"Private Sub Workbook_Open()" & vbCrLf _
& " Application.AskToUpdateLinks = False" & vbCrLf _
& " Application.DisplayAlerts = False" & vbCrLf _
& "End Sub")
wbNew.Save
wbNew.Close
The file is created and all is well, except that no code is actually added to the workbook I just made, it's a normal workbook and its ThisWorkbook is blank. (I also checked that I wasn't suppressing any warnings about the dynamic code writing, just the normal saveas prompts).
How can I make this work?
This works for me, no prompts or missing codes:
Sub test()
Dim wbnew As Workbook
Set wbnew = Workbooks.Add
Application.DisplayAlerts = False
wbnew.SaveAs Filename:="C:\temp\abc.xlsm", FileFormat:=XlFileFormat.xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
wbnew.VBProject.VBComponents.Item("ThisWorkbook").CodeModule.AddFromString ( _
"Private Sub Workbook_Open()" & vbCrLf _
& " Application.AskToUpdateLinks = False" & vbCrLf _
& " Application.DisplayAlerts = False" & vbCrLf _
& "End Sub")
wbnew.Close True
Application.DisplayAlerts = True
End Sub
For macro prompt settting Fil--> Options--> Trust Center --> Macro Setting to this will get rid of the prompt:

Resources