I have an Excel spreadsheet that contains 7 worksheets.
I need the script below to be applied to only some of the worksheets (Sheet6 & Sheet7) whenever the document is saved.
I've spent several hours trying different modifications, must of which simply did not work. The VBA debugger does not throw any errors, and when I test the script it never appears to run.
How can the script below be modified to run against specific worksheets, whenever I save the document from any of the worksheet tabs?
Thank you
VBA - Lock Cells & Protect Sheet On Save
The script below will lock cells that contain values, and then password protect the sheet before saving.
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
On Error Resume Next
Dim Cell As Range
With ActiveSheet
.Unprotect Password:=""
.Cells.Locked = False
For Each Cell In Application.ActiveSheet.UsedRange
If Cell.Value = "" Then
Cell.Locked = False
Else
Cell.Locked = True
End If
Next Cell
.Protect Password:=""
'Protect with blank password, you can change it
End With
Exit Sub
End Sub
Script Source
Change the ActiveSheet and use a For Each loop like so:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
On Error Resume Next
Dim Cell As Range
For Each sh In Array("Sheet1", "AnotherSheet", "OtherSheet")
With Sheets(sh)
.Unprotect Password:=""
.Cells.Locked = False
For Each Cell In Application.ActiveSheet.UsedRange
If Cell.Value = "" Then
Cell.Locked = False
Else
Cell.Locked = True
End If
Next
.Protect Password:=""
End With
Next
End Sub
This should help you (you'll have messages to let you know when you are in the event and when it's started and over) :
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim Cell As Range
MsgBox "Event Workbook_BeforeSave Launched", vbInformation + vbOKOnly, "Started"
On Error GoTo ErrHandler
ReTry:
With Sheet6
.Unprotect Password:=""
.Cells.Locked = False
For Each Cell In .UsedRange
If Cell.Value = "" Then
Cell.Locked = False
Else
Cell.Locked = True
End If
Next Cell
.Protect Password:=""
'Protect with blank password, you can change it
End With
With Sheet7
.Unprotect Password:=""
.Cells.Locked = False
For Each Cell In .UsedRange
If Cell.Value = "" Then
Cell.Locked = False
Else
Cell.Locked = True
End If
Next Cell
.Protect Password:=""
'Protect with blank password, you can change it
End With
MsgBox "Event Workbook_BeforeSave Over", vbInformation + vbOKOnly, "Finished"
Exit Sub
ErrHandler:
MsgBox "Error " & Err.Number & " :" & vbCrLf & _
Err.Description
Resume ReTry
End Sub
The code can be significantly shorted (run time wise) by
Using SpecialCells rather than looping through each cell
avoiding setting blank cells as being locked twice (minor compared to first point).
updated
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
For Each sh In Array("Sheet1", "AnotherSheet", "OtherSheet")
With Sheets(sh)
.Unprotect
.Cells.Locked = True
On Error Resume Next
.Cells.SpecialCells(xlBlanks).Locked = False
On Error GoTo 0
.Protect
End With
Next
End Sub
Related
I'm trying to find a way to prevent copy/cut-pasting in excel cells. I disabled copy/pasting of cells however found a flaw that if a user copies the actual value of the cell he's able to paste thus(In only 1 cell not a range of cells) making the disabled copy/paste useless.
I used the following line of code from another question:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.CutCopyMode = False
Dim UndoList As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
On Error GoTo ErrExit
UndoList = Application.CommandBars("Standard").Controls("&Undo").List(1)
If Left(UndoList, 5) = "Paste" Or UndoList = "Auto Fill" Then
MsgBox "Please don't paste values on this sheet." & vbCr & _
"The action will be reversed.", vbInformation, _
"Paste is not permitted"
With Application
.Undo
.CutCopyMode = False
End With
Target.Select
End If
ErrExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
How about using Application.Onkey.
Sub DisableCutCopyPaste()
Application.OnKey "^{c}", "" 'Copy
Application.OnKey "^{v}", "" 'Paste
Application.OnKey "^{x}", "" 'Cut
End Sub
I need some assistance with BeforeSave VBA event.
I've introduced an additional criteria using Conditional Formatting to highlight a cell if it does not equal 10 characters.
Issue is, I already have a BeforeSave event in VBA to check if a checkbox is checked, how can I combine these two statements so that it checks these two criteria before saving?
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Application.ScreenUpdating = False
Cancel = Not Worksheets(1).CheckBoxes(1).Value = 1
Dim rng As Range
For Each rng In Worksheets(1).UsedRange
If rng.DisplayFormat.Interior.Color = vbRed Then
MsgBox ("Please correct any fields highlighted in red")
Exit For
End If
Next rng
Application.ScreenUpdating = True
If Cancel Then MsgBox "Please accept the terms and conditions before saving the Invoice"
End Sub
The highlighted criteria is the one I used to evaluate the checkbox, in between is the code I'm attempting to check for any cells filled in red. Also a sample in an excel sheet.
Thanks for the help!
You were close! A couple changes:
You need to check against the cell's .DisplayFormat since that is conditional formatting.
You were exiting your subroutine before getting to your If condition. Use Exit For instead.
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Application.ScreenUpdating = False
Cancel = Not Worksheets(1).CheckBoxes(1).Value = 1
Dim rng As Range
For Each rng In ActiveSheet.UsedRange
If rng.DisplayFormat.Interior.Color = vbRed Then
Cancel = True
Exit For
End If
Next rng
Application.ScreenUpdating = True
If Cancel Then MsgBox "Please accept the terms and conditions"
End Sub
Also Application.ScreenUpdating = True needs to be outside your loop, otherwise it may never be turned back on!
UPDATE:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Application.ScreenUpdating = False
Cancel = Not Worksheets(1).CheckBoxes(1).Value = 1
Dim rng As Range
For Each rng In Worksheets(1).UsedRange
If rng.DisplayFormat.Interior.Color = vbRed Then
MsgBox ("Please correct any fields highlighted in red")
Cancel = True
Application.ScreenUpdating = True
Exit Sub
End If
Next rng
Application.ScreenUpdating = True
If Cancel Then MsgBox "Please accept the terms and conditions before saving the Invoice"
End Sub
I'm trying to ensure that for each row in my spreadsheet, if cell B or C is not populated (in the range), then a message box alerts the user - and doesn't allow it to be saved.
I have the workbook saved as a Macro enabled (XLSM) file - but the Workbook_BeforeSave doesn't appear to be triggering.
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim rng1 As Range
Dim rng2 As Range
MsgBox "hi"
Set rng1 = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(3, 4)).Select
Stop
'turn off events to avoid code retriggering itself
Application.EnableEvents = False
For Each rng2 In rng1
If Cells(rng2.Row, "B") = vbNullString Then
MsgBox "Please Enter Something in Cell B - your entry will be deleted", vbOKOnly
rng2.Value = vbNullString
End If
If Cells(rng2.Row, "C") = vbNullString Then
MsgBox "Please Enter Something in Cell C - your entry will be deleted", vbOKOnly
rng2.Value = vbNullString
End If
Next
Application.EnableEvents = True
End Sub
Can anyone see where I may have gone wrong? Macros are enabled for the workbook.
Thanks for any advice,
Mark
Somehow in your code, you have disabled the events, thus the Save event is not caught. Try the following:
Press Ctrl + G, while you are selecting the Visual Basic Editor;
Write Application.EnableEvents = True on the Immediate window that shows up;
Press Enter;
Now the events would be activated.
As mentioned by Jeep, using error handling is a good idea in this case, thus the events are always enabled back if something "bad" happens during code execution:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
On Error GoTo Workbook_BeforeSave_Error
'code here
On Error GoTo 0
Exit Sub
Workbook_BeforeSave_Error:
Application.EnableEvents = True
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Workbook_BeforeSave"
End Sub
Big thanks to A.S.H for helping me with out with this code earlier.
Right now, I'm attempting to show a splash sheet that tells users to enable macros in order to access the workbook. The plan is to save the file with the splash sheet visible and other sheets veryhidden during the BeforeClose event. During the Open event, the splash sheet will be made veryhidden and the other sheets will be made visible.
Hence, the user will only see the splash sheet when he/she opens the file with macros disabled. However with the below code, it doesn't seem as though the routine that makes the splash sheet visible and the rest veryhidden is running. Where have I gone wrong?
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim rs As Object, ws As Object
Dim Ans As Integer
Dim target As Range, r As Range
Set rs = Sheets("Report")
If Me.Saved = False Then
Do
Ans = MsgBox("Do you want to save the changes you made to '" & _
Me.Name & "'?", vbQuestion + vbYesNoCancel)
Select Case Ans
Case vbYes
With rs
Set target = .Range("B5:R" & .Cells(.Rows.Count, 2).End(xlUp).Row)
End With
target.Value = Application.Trim(target.Value)
For Each r In target.Rows
If Not IsEmpty(r.Cells(1)) And Application.CountIf(r, "") > 0 Then
Cancel = True
r.Parent.Activate: r.Activate
MsgBox ("Please confirm all required fields have been completed")
Exit Sub
End If
Next
Application.ScreenUpdating = False
Sheets("Reminder").Visible = xlSheetVisible
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Reminder" Then
ws.Visible = xlSheetVeryHidden
End If
Next ws
ActiveWorkbook.Save
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Reminder" Then
ws.Visible = xlSheetVisible
End If
Next ws
Sheets("Reminder").Visible = xlSheetVeryHidden
ThisWorkbook.Saved = True
Application.ScreenUpdating = True
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
Loop Until ThisWorkbook.Saved = True
End If
End Sub
If you are experiencing screen trouble, it is likely due to some erroneous manipulation of Application.ScreenUpdating here and in other macros. In this one, the error is that you first set it to False and then Exit Sub without restoring it to True.
Moreover, since your routine only does calculation (checking) and does not change cell values, there's no point in disabling Application.ScreenUpdating.
On a side note, I think your routine that checks for empty cells can be much simplified.
Function dataIsValid() As Boolean
Dim target As Range, r As Range
With ActiveSheet ' <-- May be better change to some explicit sheet name
Set target = .Range("B5:R" & .Cells(.Rows.Count, 2).End(xlUp).Row)
End With
target.value = Application.Trim(target.value) ' <-- trim the whole range
For Each r In target.Rows
If Not IsEmpty(r.Cells(1)) And Application.CountIf(r, "") Then
r.Parent.Activate: r.Activate ' <-- Show erroneous row
MsgBox ("Please confirm all required fields have been completed")
Exit Function
End If
Next
dataIsValid = True
End Function
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Cancel = Not dataIsValid
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Cancel = Not dataIsValid
End Sub
I have a macro up and running that sorts a pivot table, copies a range of cells out of the table and then pastes those into a second sheet. To be honest, with where I'm at with VBA right now I'm pretty happy with this feat alone. Yet I have more things I want it to do.
What I want to happen is this: The macro I have pastes data into the first empty cells in column A. When this happens I want the macro to enter today's date (preferably in a manner that makes it permanent and won't change to tomorrow's date tomorrow) in the same row in column C and the text "IV020" into column D.
In Sheet9 I have the following code (mainly taken from posts here):
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aCell As Range
On Error GoTo Whoa
Application.EnableEvents = False
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Not Target.Columns.Count > 1 Then
For Each aCell In Target
If aCell.Value <> "" And aCell.Offset(0, 2).NumberFormat = "" Then
aCell.Offset(0, 2).Value = "=TODAY()"
aCell.Offset(0, 3).Value = "IV020"
End If
Next
Else
MsgBox "Please paste in 1 Column"
End If
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Yet when things are pasted or entered manually into Column A, nothing happens.
You cannot have a Range.NumberFormat property that is a zero-length string. Even if you tried to put one in manually, it would reset itself to General.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns(1)) Is Nothing Then
'don't do things until you have to
On Error GoTo Whoa
Application.EnableEvents = False
Dim aCell As Range
'this processes all of the cells that were changes in column A
For Each aCell In Intersect(Target, Columns(1))
'If aCell.Value <> "" And aCell.Offset(0, 2).NumberFormat = "" Then
If aCell.Value <> "" Then
aCell.Offset(0, 2).Value = Date 'possibly Now but likely not "=TODAY()"
aCell.Offset(0, 3).Value = "IV020"
End If
Next
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
I've made some minor changes; you will have to decide what you want to do about the .NumberFormat issue.