It has been a while i'm blocked with vba code running when event occured.
For a brief explanation, before the user save the file a userform pop-up in order to select the name for the file and the version. When he click continue, the getsaveasfilename start and the file will save in the proper location. Nevertheless, when saving the workbook crash and excel close all the file.
Please see below the code :
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim sfile, mbox As Variant, cell_path As String
dialog:
save_file.Show
cell_path = ActiveWorkbook.Sheets("ENGINE").Range("H1") & " CAPEX " & ActiveWorkbook.Sheets("ENGINE").Range("I1")
sfile = Application.GetSaveAsFilename(cell_path, "Excel Macro Files, *.xlsm")
If sfile = False Then
Cancel = True
Exit Sub
End If
If Dir(sfile) = "" Then
Application.DisplayAlerts = False
Application.EnableEvents = False
ActiveWorkbook.SaveAs sfile
Application.DisplayAlerts = True
Exit Sub
Else: mbox = MsgBox("The file already exist, do you want to overwrite ?", vbYesNo, "WARNING")
If mbox = vbYes Then
Application.DisplayAlerts = False
Application.EnableEvents = False
ActiveWorkbook.SaveAs sfile
Application.DisplayAlerts = True
Else: GoTo dialog
End If
End If
Application.EnableEvents = True
End Sub
Related
I have the following code that will open/save/close any/all workbooks in a folder. It works great, however, I also need it to include sub folders. The code needs to work without restrictions on the number of folders, sub folders and files, if possible.
I'm working with Excel 2010 and I'm new to VBA - would really appreciate any help!
Sub File_Loop_Example()
'Excel VBA code to loop through files in a folder with Excel VBA
Dim MyFolder As String, MyFile As String
'Opens a file dialog box for user to select a folder
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
MyFolder = .SelectedItems(1)
Err.Clear
End With
'stops screen updating, calculations, events, and statsu bar updates to help code run faster
'you'll be opening and closing many files so this will prevent your screen from displaying that
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'This section will loop through and open each file in the folder you selected
'and then close that file before opening the next file
MyFile = Dir(MyFolder & "\", vbReadOnly)
Do While MyFile <> ""
DoEvents
On Error GoTo 0
Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False
ActiveWorkbook.Save
Workbooks(MyFile).Close SaveChanges:=True
MyFile = Dir
Loop
'turns settings back on that you turned off before looping folders
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
MsgBox "Done!"
End Sub
For anyone interested, I found an alternative which I managed to adapt and does exactly what I want:
Sub Loop_Example()
Dim MyFolder As String
Dim file As Variant, wb As Excel.Workbook
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
MyFolder = .SelectedItems(1)
Err.Clear
End With
Application.ScreenUpdating = False
For Each file In Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & startFolder & "*.xl*"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
Set wb = Workbooks.Open(file)
ActiveWorkbook.Save
wb.Close SaveChanges:=True
Set wb = Nothing
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
I save all worksheets in a workbook as individual CSV files.
If I make a change to any of the worksheets and run the macro again, it prompts me with the "A file named ... already exists in this location. Do you want to replace it?".
If I click Yes, the prompt comes up for every worksheet. If I click no, the macro throws an error.
Is there a way to avoid the prompt?
Sub CSVAutomation()
Dim ws As Worksheet, wb As Workbook
Dim pathh As Variant
Set wb = ActiveWorkbook
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then 'a folder was picked
pathh = .SelectedItems(1)
End If
End With
If pathh = False Then Exit Sub 'no folder picked; pathh is false
Application.ScreenUpdating = False
For Each ws In wb.Sheets(Array("01 - Currencies", ...."14 - User Defined
Fields"))
ws.Copy
With ActiveWorkbook
'Application.DisplayAlerts = False 'to avoid overwrite warnings
' pathh is a string (variant) of the path of the folder; does not
need pathh.Path
.SaveAs pathh & "\" & ws.Name, xlCSV
.Close SaveChanges:=False
End With
Next ws
Application.ScreenUpdating = True
End Sub
Check my comment and (as Portland Runner says) you could turn off some alerts
I used this
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AutomationSecurity = msoAutomationSecurityForceDisable
Application.AskToUpdateLinks = False
Using a procedure to put inside and used every time to turn it of and another to turned on helpme a lot with all the alerts.
Sub Alerts(ScreenUpdate As Boolean, DisplayAlerts As Boolean, AutoSecurity As Boolean, AskToUpdate As Boolean)
Application.ScreenUpdating = ScreenUpdate
Application.DisplayAlerts = DisplayAlerts
Application.AutomationSecurity = IIf(AutoSecurity, msoAutomationSecurityForceDisable, msoAutomationSecurityByUI)
Application.AskToUpdateLinks = AskToUpdate
End Sub
I have a macro template file. It shows save as dialog box with ".xls" format as default. I want to show the default type as ".xlsm". I need to do it using vba.
Please anyone help me in solving this.
Thanks in advance!!!
Please refer the following code. It works for me!!
Dim FileSaveAsName As Variant, intchoice As Integer
Static saveProcess As Boolean
If Not saveProcess Then
Application.EnableEvents = False
Application.DisplayAlerts = False
If SaveAsUI = True Then 'Save As... was selected
saveProcess = True
Set FileSaveName = Application.FileDialog(msoFileDialogSaveAs)
FileSaveName.InitialFileName = ThisWorkbook.Name
FileSaveName.FilterIndex = 2 'select to save with a ".xlsm" extension
intchoice = FileSaveName.Show
If intchoice <> 0 Then
FileSaveName.Execute
End If
Cancel = True
Else 'Normal Save
saveProcess = True
Cancel = True
ThisWorkbook.Save
End If
saveProcess = False
Application.EnableEvents = True
Application.DisplayAlerts = True
End If
I copied and edited some code i found in this stackoverflow question:
Loop through all worksheets in all Excel workbooks in a folder to change the font, font size, and alignment of text in all cells
Although the code does un/protect the sheet (still a work in progress, will eventually be a toggle), when i open the workbooks later the workbook window is hidden and i have to manually press the 'unhide window' icon in the 'view' ribbon. I can't see anything in the code which triggers a 'hide'. Does anyone have any clues how to prevent/workaround this?
my version:
Sub fAMWToggleProtection()
Const fPath As String = "S:\SHARED\Cidmls\MasterMix Section\Copy of Master Mix templates for testing\"
Dim sh As Worksheet
Dim sName As String
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
sName = Dir(fPath & "*.xls*")
Do Until sName = ""
With GetObject(fPath & sName)
For Each sh In .Worksheets
With sh
.Visible = True
.Unprotect Password:="icpmr"
' .Protect Password:="icpmr"
End With
Next sh
' .Save
' .Close True
Debug.Print sName
End With
sName = Dir
Loop
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox "Complete", vbOKOnly, "Uprotect all sheets"
On Error GoTo 0
Exit Sub
fAMWToggleProtection_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in fAMWToggleProtection of Module1"
End Sub
Try:
With GetObject(fPath & sName)
.Windows(1).Visible = True ' <-- Not tested, but assuming this is a Workbook object
For Each sh In .Worksheets
This is a follow up from this question, Lock Cells after Data Entry. I have progressed from asking that question but encountered more problems so felt I should ask a new question. The workbook is edited by multiple users. To prevent tampering with previous data the cells are locked once data has been entered and the file saved.
I have a couple of small bugs in the code:
If the user chooses to SaveAs then tries to save over an existing file the usual ' Do you want to replace this file?' dialog appears. If the user selects no there is a run time error. I have highlighted where the error is in the code below but I am unsure how to fix it.
If the user has entered data then tries to exit and save the file using the save dialog box that appears on close the file is saved but the data is not locked. I have been trying to call my main code to lock the cells upon an exit save but I keep encountering argument not optional errors.
Here is the full code:
Option Explicit
Const WelcomePage = "Macros"
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Written by Alistair Weir (alistair.weir#communitypharmacyscotland.org.uk, http://alistairweir.blogspot.co.uk/)
Dim ws As Worksheet
Dim wsActive As Worksheet
Dim vFilename As Variant
Dim bSaved As Boolean
'Turn off screen updating
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Record active worksheet
Set wsActive = ActiveSheet
'Prompt for Save As
If SaveAsUI = True Then
MsgBox "Are you sure you want to save? Data entered cannot be edited once the file has been saved. Press cancel on the next screen to edit your data or continue if you are sure it is correct.", vbCritical, "Are you sure?"
vFilename = Application.GetSaveAsFilename("", fileFilter:="Excel Files (*.xls), *.xls")
If CStr(vFilename) = "False" Then
bSaved = False
Else
'Save the workbook using the supplied filename
Call HideAllSheets
'--> The vFilename Variant in the next line is the problem **
'--> when trying to overwrite an existing file **
ThisWorkbook.SaveAs vFilename
Application.RecentFiles.Add vFilename
Call ShowAllSheets
bSaved = True
End If
Else
'Save the workbook, prompt if normal save selected not save As
Call HideAllSheets
If MsgBox("Are you sure you want to save? Data entered cannot be edited after saving", vbYesNo, "Save?") = vbYes Then
ThisWorkbook.Save
Call ShowAllSheets
bSaved = True
Else
Cancel = True
End If
Call ShowAllSheets
End If
'Restore file to where user was
wsActive.Activate
'Restore screen updates
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Set application states appropriately
If bSaved Then
ThisWorkbook.Saved = True
Cancel = True
Else
Cancel = True
End If
'Lock Cells before save if data has been entered
Dim rpcell As Range
With ActiveSheet
If bSaved = True Then
.Unprotect Password:="oVc0obr02WpXeZGy"
.Cells.Locked = False
For Each rpcell In ActiveSheet.UsedRange
If rpcell.Value = "" Then
rpcell.Locked = False
Else
rpcell.Locked = True
End If
Next rpcell
.Protect Password:="oVc0obr02WpXeZGy"
Else
MsgBox "The LogBook was not saved. You are free to edit the RP Log again", vbOKOnly, "LogBook Not Saved"
End If
End With
End Sub
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Call ShowAllSheets
Application.ScreenUpdating = True
ThisWorkbook.Saved = True
End Sub
'Called to hide all the sheets but enable macros page
Private Sub HideAllSheets()
Dim ws As Worksheet
Worksheets(WelcomePage).Visible = xlSheetVisible
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
Next ws
Worksheets(WelcomePage).Activate
End Sub
'Called to show the data sheets when macros are enabled
Private Sub ShowAllSheets()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
Next ws
Worksheets(WelcomePage).Visible = xlSheetVeryHidden
End Sub
Thanks :)
Edit
For now I am solving problem 2 by bypassing excel's default 'do you want to save?' by doing this:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If MsgBox("Are you sure you want to quit? Any unsaved changes will be lost.", vbYesNo, "Really quit?") = vbNo Then
Cancel = True
Else
ThisWorkbook.Saved = True
Application.Quit
End If
End Sub
I am open to suggestions of a better way and still haven't solved the first problem.
One possibility is to write your own confirmations in a save function, like so:
Private Function SaveSheet(Optional fileName) As Boolean
HideAllSheets
If fileName = "" Then
ThisWorkbook.Save
SaveSheet = True
Else
Application.DisplayAlerts = False
If Dir(fileName) <> "" Then
If MsgBox("Worksheet exists. Overwrite?", vbYesNo, "Exists") = vbNo Then Exit Function
End If
ThisWorkbook.saveAs fileName
SaveSheet = True
Application.DisplayAlerts = True
End If
ShowAllSheets
End Function
And change your original code to something like:
If SaveAsUI Then
If MsgBox( _
"Are you sure you want to save? Data entered cannot be edited once the file has been saved. " & _
"Press cancel on the next screen to edit your data or continue if you are sure it is correct.", _
vbYesNo, "Are you sure?" _
) = vbYes Then
vFilename = Application.GetSaveAsFilename("", fileFilter:="Excel Files (*.xls), *.xls")
If vFilename <> "" Then
If SaveSheet(vFilename) Then bSaved = True
End If
End If
Else
If MsgBox( _
"Are you sure you want to save? Data entered cannot be edited after saving", _
vbYesNo, "Save?" _
) = vbYes Then
If SaveSheet("") Then bSaved = True
End If
End If
I've not fully tested the above, but it should give you some ideas.