I am still having problems with the following code and not sure where to start fixing it. When a user tries to close, I would like it to save a copy with a timestamp in the current directory where it launched from.
Private Sub Workbook_BeforeClose(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sFileName As String
Dim sDateTime As String
Dim txtFileName As String
'0. Set new filename with timestamp.
With ThisWorkbook
sDateTime = " (" & Format(Now, "yyyy-mm-dd hhmm") & ").xlsm"
sFileName = "2018 Testy" & sDateTime
'1. Check of Save As was used.
If SaveAsUI = True Then
Cancel = True
'2. Call up your own dialog box. Cancel out if user Cancels in the dialog box.
txtFileName = Application.GetSaveAsFilename(sFileName, "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm", , "Save As XLSM file")
If txtFileName = "False" Then
MsgBox "Action Cancelled", vbOKOnly
Cancel = True
Exit Sub
End If
'3. Save the file.
Application.EnableEvents = False
ThisWorkbook.SaveAs FileName:=txtFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.EnableEvents = True
End If
End Sub
Use the below code.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim sFileName As String
Dim sDateTime As String
sDateTime = " (" & Format(Now, "yyyy-mm-dd hhmm") & ").xlsm"
sFileName = ThisWorkbook.Path & "\2018 Testy" & sDateTime
Application.EnableEvents = False
ThisWorkbook.SaveAs Filename:=sFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.EnableEvents = True
End Sub
Related
I am trying to make a copy of a workbook that I have, based on list of IDs. I have got this to work OK if I hard code the path, however I can't figure out how to do this where specifying the path using msoFileDialogFolderPicker.
I have tried a number of variations depending on what I have found online and have got as far as below but stuck. Help appreciated.
Dim xFilepath As Variant
Dim xFilename As String
xFilepath = Application.FileDialog(msoFileDialogFolderPicker)
xFilename = Range("Table9[ProgramID]") & " Product Financial Allocation" & ".xlsb"
With xFilepath
.Title = "Choose Destination"
.SHOW
mypath = .SelectedItems(1) & "\"
End With
mypath = mypath
Sheets("FILES").Range("A3").Select
For i = 1 To 3
Sheets("FILES").Range("A" & i).copy Sheets("TEMPLATE").Range("Table9[ProgramID]")
ActiveWorkbook.SaveCopyAs Filename:=mypath & Filename
FileFormat = 50
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Workbooks.Open Filename:=mypath & Filename
Call DeleteQueries
ActiveWorkbook.Save
ActiveWorkbook.Close
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
You can use the following code can be used to select folder and then you can append the folder path with file name.
Sub ChooseFolder()
Dim sFolder As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1)
End If
End With
Filename = "Test.xlsx"
Filepath = sFolder + "\" + Filename
If sFolder <> "" Then ' if a file was chosen
MsgBox Filepath 'Use this for further processing
End If
End Sub
Following code can be used select single file.
Private Sub ChooseFile()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Please select the file."
.Filters.Clear
.Filters.Add "Excel File", "*.xlsx"
If .Show = True Then
txtFileName = .SelectedItems(1) 'replace txtFileName with your textbox
End If
End With
MsgBox txtFileName
End Sub
Writing a code to save a file with a defined filename to a specific folder entered by the user. However the file is being saved in a location previous to the specified location. For example I provide file save path as "C:\Users\arorapr\Documents\PAT" but the file is saving it in the path "C:\Users\arorapr\Documents". I have written the below code.
File_Name = Format(Now(), "DDMMYYYY") & "_" & LName & EmpIN & "_" & Range("C6").Value & "_" & Range("J3").Value & "_" & "PAT"
Application.DisplayAlerts = False
MsgBox "Please select the folder to save PAT"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
End With
ActiveWorkbook.saveas Filename:=File_Name & ".xlsm", FileFormat:=52
Application.DisplayAlerts = True
ActiveWorkbook.Close
Your challenge is that you're opening a file dialog, but not using the user's choice from that in the saveas. Try something along these lines:
Sub SaveFile()
Dim FolderName As String
File_Name = Format(Now(), "DDMMYYYY") & "_" & LName & EmpIN & "_" & Range("C6").Value & "_" & Range("J3").Value & "_" & "PAT"
Application.DisplayAlerts = False
MsgBox "Please select the folder to save PAT"
' Pop up the folder-selection box to get the folder form the user:
FolderName = GetFolder()
' If the user didn't select anything, you can't save, so tell them so:
If FolderName = "" Then
MsgBox "No folder was selected. Program will terminate."
Exit Sub
End If
' Create a path by combining the file and folder names:
File_Name = FolderName & "\" & File_Name & ".xlsm"
ActiveWorkbook.SaveAs Filename:=File_Name, FileFormat:=52
Application.DisplayAlerts = True
ActiveWorkbook.Close
End Sub
' A separate function to get the folder name and return it as a string
Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Hope that helps.
In your code, you are not saving the path of the selected folder to a variable. In the code below, the path is saved to the variable selectedFolder, which gets its value from fldr.SelectedItems(1). Then the path + "\" + YourFileName & .xlsm is saved:
Option Explicit
Sub TestMe()
Dim fldr As FileDialog
Dim selectedFolder As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.Show
selectedFolder = .SelectedItems(1)
End With
ActiveWorkbook.SaveAs Filename:=selectedFolder & "\" & "YourFileName" & ".xlsm"
End Sub
Or alternatively, you may use a function, returning the folder's path from here:
VBA - Folder Picker - set where to start
A robust funciton, that I am using to GetFolder is this one:
Option Explicit
Sub myPathForFolder()
Debug.Print GetFolder(Environ("USERPROFILE"))
End Sub
Function GetFolder(Optional InitialLocation As String) As String
On Error GoTo GetFolder_Error
Dim FolderDialog As FileDialog
Dim SelectedFolder As String
If Len(InitialLocation) = 0 Then InitialLocation = ThisWorkbook.Path
Set FolderDialog = Excel.Application.FileDialog(msoFileDialogFolderPicker)
With FolderDialog
.Title = "My Title For Dialog"
.AllowMultiSelect = False
.InitialFileName = InitialLocation
If .Show <> -1 Then GoTo GetFolder_Error
SelectedFolder = .SelectedItems(1)
End With
GetFolder = SelectedFolder
On Error GoTo 0
Exit Function
GetFolder_Error:
Debug.Print "Error " & Err.Number & " (" & Err.Description & ")
End Function
I am trying to create backup copy of workbook .xlsm and save it as .xlsx
due to the same issue as here: Run time error '1004': Copy method of worksheet class failed - Temp file issue
I cannot use SaveCopyAs along with changing format of file
My workaround was to
create new copy of .xlsm file
open this new copy
save it as .xlsx
Close .xlsx file
Remove file from step 1
this is my code
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
On Error GoTo ErrorHandler:
'define variables
Dim backupfolder As String
Dim strFileName As String
Dim xlsxStrFileName As String
Dim fullPath As String
Dim xlsxFullPath As String
Dim wkb As Workbook
'get timestamp
dt = Format(CStr(Now), "yyyymmdd_hhmmss")
'construct full path to backup file which will be later converted to .xlsx
backupfolder = "c:\work\excel macro\delete\"
strFileName = "Test_iz_" & dt & ".xlsm"
fullPath = "" & backupfolder & strFileName
xlsxStrFileName = "Test_iz_" & dt & ".xlsx"
xlsxFullPath = "" & backupfolder & xlsxStrFileName
ActiveWorkbook.SaveCopyAs Filename:=fullPath
Set wkb = Workbooks.Open(fullPath)
wkb.Activate
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=xlsxFullPath, FileFormat:=51 'saves the file
Application.DisplayAlerts = True
'Application.Wait (Now + TimeValue("00:00:03"))
ActiveWorkbook.Close
Kill fullPath
Exit Sub
ErrorHandler:
MsgBox "An error occured " & vbNewLine & vbNewLine & Err.Number & ": " & Err.Description
MsgBox "Backup saved: " & xlsxFullPath
ActiveWorkbook.SaveAs Filename:=fullPath
End Sub
My problem is that i always end up in ErrorHandler, even though i got expected result
When i comment out line 2
On Error GoTo ErrorHandler:
error Run-time error '91': Object variable or With block variable not set
on Debug, it points to row with the code
wkb.Activate
and .xlsm file is not deleted
I guess the problem is that when i create new copy of xlsm file and save it, this entire code would be executed one more time and that issue is there somewhere, but i cannot find it.
Thank you
This worked on my computer:
Sub Workbook_BeforeSave()
On Error GoTo ErrorHandler:
'define variables
Dim backupfolder As String
Dim strFileName As String
Dim xlsxStrFileName As String
Dim fullPath As String
Dim xlsxFullPath As String
Dim wkb As Workbook
'get timestamp
dt = Format(CStr(Now), "yyyymmdd_hhmmss")
'construct full path to backup file which will be later converted to .xlsx
backupfolder = "c:\work\excel macro\delete\"
strFileName = "Test_iz_" & dt & ".xlsm"
fullPath = "" & backupfolder & strFileName
xlsxStrFileName = "Test_iz_" & dt & ".xlsx"
xlsxFullPath = "" & backupfolder & xlsxStrFileName
ActiveWorkbook.SaveAs Filename:=fullPath, FileFormat:=52
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=xlsxFullPath, FileFormat:=51 'saves the file
Application.DisplayAlerts = True
ActiveWorkbook.Close
Kill fullPath
Exit Sub
ErrorHandler:
MsgBox "An error occured " & vbNewLine & vbNewLine & Err.Number & ": " & Err.Description
MsgBox "Backup saved: " & xlsxFullPath
ActiveWorkbook.SaveAs Filename:=fullPath
End Sub
Cheers,
Jonathan
I have the following WB code which tries to force the user to save the file as a particular file type (.xlsm) and name (the default path & "username-gaplist" --> can be followed by ANY type after this). So far I'm almost got it working down pat, except for 1 issue with the comparison operator in the IF statement.
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim txtFileName As String
Dim yn As Boolean
Dim a As String
a = Application.DefaultFilePath & "\" & Environ("UserName") & "-Gaplist.xlsm"
'1. Check of Save As was used.
If SaveAsUI = True Then
Cancel = True
'2. Call up your own dialog box. Cancel out if user Cancels in the dialog box.
txtFileName = Application.GetSaveAsFilename(Environ("UserName") & "-Gaplist", "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm", , "Save As XLSM file")
'this compares the named file by user to the restriction which is username and gap list, and cancels if non-confmring
If Left(txtFileName, Len(txtFileName)) >= Left(a, Len(txtFileName)) Then
MsgBox Left(txtFileName, Len(txtFileName)) & vbLf & Left(a, Len(txtFileName))
'if user hits cancel (returns value of "False")
If txtFileName = "False" Then
MsgBox "Action Cancelled", vbOKOnly
Cancel = True
Exit Sub
End If
'if an invalid string is entered
Else
MsgBox "Must be saved in following format:" & vbLf & Application.UserName & "-Gaplist" & " " & "(you can add whatever after this)", vbOKOnly, "Retry.."
Cancel = True
Exit Sub
End If
'3. Save the file based on string entered
Application.EnableEvents = False
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=txtFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.EnableEvents = True
Application.DisplayAlerts = True
MsgBox "Saved to: " & txtFileName, vbExclamation, Now
End If
End Sub
Like I said, I know that the issue lies in the
Left(txtFileName, Len(txtFileName)) >= Left(a, Len(txtFileName))
and the Cancel function works correctly in this setup, but I tested and this is what happens:
Entered: username-gaplist.xlsm String(fixed): username-gaplist.xlsm
result: GOOD (will overwrite if already saved as display events gets
turned off) Entered: usernam.xlsm String(fixed):
username-gaplist.xlsm result: Good (will give the user's the msgbox
telling them to retry as it doesn't conform)
Entered: username-gaplist323423.xlsm String(fixed):
username-gaplist.xlsm result: Good (will save accordingly to the
specified file path)
Entered: userzzz.xlsm String(fixed): username-gaplist.xlsm result:
BAD - this is allowing the user to save because adding the "z" means that the entered string is > than the fixed string (based on
same length), and it saves this . I would like to fix this
Entered: (user hits cancel) String(fixed): username-gaplist.xlsm
result: Msgbox action cancelled - exits sub
The other thing I could try is to use a "LIKE" operator , but have little experience using this.
Anyone provide any thoughts/suggestions would be great!
THanks
Figured it out.
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim txtFileName As String
Dim yn As Boolean
Dim a As String
a = Application.DefaultFilePath & "\" & Environ("UserName") & "-Gaplist"
'1. Check of Save As was used.
If SaveAsUI = True Then
Cancel = True
'2. Call up your own dialog box. Cancel out if user Cancels in the dialog box.
txtFileName = Application.GetSaveAsFilename(Environ("UserName") & "-Gaplist", "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm", , "Save As XLSM file")
'this compares the named file by user to the restriction which is username and gap list, and cancels if non-confmring
If txtFileName = "False" Then
MsgBox "Action Cancelled", vbExclamation, "Cancelled.."
Cancel = True
Exit Sub
ElseIf Left(WorksheetFunction.Substitute(txtFileName, ".xlsm", ""), Len(a)) = a Then
GoTo ResumeSub
ElseIf Left(WorksheetFunction.Substitute(txtFileName, ".xlsm", ""), Len(a)) <> a Then
MsgBox "Must be saved in the following format: " & Chr(10) & Chr(10) & _
Environ("username") & "-Gaplist" & "(you can enter whatever text after this)" & vbLf & vbLf & _
"Note: Not case sensitive!", vbCritical, "Retry.."
Cancel = True
Exit Sub
End If
'3. Save the file.
ResumeSub:
Application.EnableEvents = False
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=txtFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.EnableEvents = True
Application.DisplayAlerts = True
MsgBox "Saved to: " & txtFileName & vbLf & vbLf & Space(15) & Date & " " & Time, vbInformation, "Saved!"
End If
End Sub
The Code:
mNummer = InputBox("Please typ a number")
If mNummer = ""
Then MsgBox ("Makro wont function!")
Exit Sub
End If
Year= InputBox("Select Year", Worksheets("Vorgaben").Range("B14").Value)
If Year= ""
Then
MsgBox("Makro wird abgebrochen!")
Exit Sub
End If
Welle = InputBox("Bitte Welle auswählen", , "0" & Worksheets("Vorgaben").Range("B15"))
If Welle = "" Then MsgBox ("Makro wird abgebrochen!")
Exit Sub
End If
'Combine the variables in mNummerGanz '
mNummerGanz = mNummer & "_" & Year& "_" & Welle
Worksheets("Eingabefeld").Range("F2").Value =mNummerGanz
The Question:
So here i combined 3 variables, which are asking for user Inputs with 3 messageboxes. Now the combined Version of it is in variable "mNummerGanz".
Now I would like to open any Excel file by going to any Directory and selecting it. But my macro should check if the Name of the selected Excel file is equals "mNummerGanz.xls". If yes, the file should be opened, if it is not equal to "mNummerGanz.xls" then it should print "error".
Does anyone have Suggestion for this ?
If I've understood correctly, you're building a string which you then want to test to see if it's a valid file name, and if so, open it?
In which case, this snippet should do that for you
If Len(Dir(outputpath & mNummerGanz)) <> 0 Then
Workbooks.Open (outputpath & mNummerGanz)
Else
MsgBox ("That file does not exist")
End If
It checks to see if the file exists (outputpath = folder location)
and if so, opens it.
I can help! Also in German :) Ich kann dir auf Deutsch helfen :)
mNummer = InputBox("Please typ a number")
If mNummer = "" Then
MsgBox ("Makro wont function!")
Exit Sub
End If
Year= InputBox("Select Year", Worksheets("Vorgaben").Range("B14").Value)
If Year= "" Then
MsgBox("Makro wird abgebrochen!")
Exit Sub
End If
Welle = InputBox("Bitte Welle auswählen", , "0" &
Worksheets("Vorgaben").Range("B15").Value
If Welle = "" Then
MsgBox ("Makro wird abgebrochen!")
Exit Sub
End If
'Combine the variables in mNummerGanz '
mNummerGanz = mNummer & "" & Year& "" & Welle
Worksheets("Eingabefeld").Range("F2").Value =mNummerGanz
ANSWER:
'typical excel variables
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Retrieve Target FilePath From User
Set FldrPicker = Application.FileDialog(msoFileDialogFilePicker)
With FldrPicker
.Title = "Select A Target File"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
If myFile = "mNummerGanz.xls"
Debug.Print "myFile = " & myFile
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Do your stuff here, man.
With wb.Worksheets(1)
'add in your string manipulation / cell dumping here
'with a few lines
End With
'Close opened *.xls, save
wb.Close SaveChanges:=True
Else
GoTo ResetSettings
End If
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True