I have protected sheets 4 with a password because there are some cells that users aren't allowed to input in those cells in sheet 4. The password is 1234.
But, I want to run my macro, and if there is an error, the cell will be highlight automatically.
My macro doesn't run and error, because the cell that I want to highlight is in protected sheet.
How to make the sheet 4 stay protected and make my macro keep running when I click the validation button?
Private Sub commandbutton1_click()
FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:=1234, WriteResPassword:=1234, _
ReadOnlyRecommended:=False, CreateBackup:=False
vehicle = Sheets("4").Range("K22")
expenditure_gasoline = Sheets("4").Range("M22")
If vehicle = true and expenditure_gasoline = 0 Then
MsgBox "it should not be empty", vbcritical
End If
If vehicle = true and expenditure_gasoline = 0 Then Sheets("4").Range("M22").Interior.ColorIndex = 3
End sub
Try the changes bellow (untested)
V1 - Protect the sheet from user changes, but not VBA changes UserInterfaceOnly:=True
Option Explicit
Private Sub commandbutton1_click()
Const PATH_AND_FILENAME = "C:\YourTestFile.xlsx" '<------ Update this path & file name
Dim wb As Workbook, ws As Worksheet, vehicle As Variant, expenditureGasoline As Variant
Set wb = Workbooks.Open(Filename:=PATH_AND_FILENAME, WriteResPassword:="1234", _
Password:="1234", Format:=xlOpenXMLWorkbookMacroEnabled)
Set ws = wb.Sheets("4")
ws.Protect Password:="1234", UserInterfaceOnly:=True '<--- Protect changes from UI only
Set vehicle = ws.Range("K22")
Set expenditureGasoline = ws.Range("M22")
If Not IsError(vehicle) And Not IsError(expenditureGasoline) Then
If vehicle = True And expenditureGasoline = 0 Then
ws.Range("M22").Interior.ColorIndex = 3
MsgBox "Cell M22 should not be empty", vbExclamation
End If
End If
End Sub
V2 - Unprotect before the change, and Protect back after the change
Private Sub commandbutton1_click()
Const PATH_AND_FILENAME = "C:\YourTestFile.xlsx" '<------ Update this path & file name
Dim wb As Workbook, ws As Worksheet, vehicle As Variant, expenditureGasoline As Variant
Set wb = Workbooks.Open(Filename:=PATH_AND_FILENAME, WriteResPassword:="1234", _
Password:="1234", Format:=xlOpenXMLWorkbookMacroEnabled)
Set ws = wb.Sheets("4")
Set vehicle = ws.Range("K22")
Set expenditureGasoline = ws.Range("M22")
If Not IsError(vehicle) And Not IsError(expenditureGasoline) Then
If vehicle = True And expenditureGasoline = 0 Then
ws.Unprotect "1234" '<--- Unprotect it before the change
ws.Range("M22").Interior.ColorIndex = 3
ws.Protect "1234" '<--- Protect it back, after the change
MsgBox "Cell M22 should not be empty", vbExclamation
End If
End If
End Sub
Related
Is there a way to prevent Excel from closing if cell B34 > 0 and J34 = 0?
If they leave B34 alone then J34 doesn't need to be filled in and the workbook can close.
If they enter data into B34 we need info in J34 as well.
Something like this:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Application.Sheets("Sheet1").Range("B34").Value > "" and _
Application.Sheets("Sheet1").Range("B34").Value = "" Then
Cancel = True
MsgBox "Please fill in the total % in cell J34"
End If
End Sub
In the ThisWorkbook object:
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
If ws.Range("B34").Value <> "" And ws.Range("J34").Value = "" Then
Cancel = True
MsgBox "Please fill in the total % in cell J34"
End If
End Sub
I'm adding a new worksheet to my workbook with
Application.ScreenUpdating = False
SheetExists = False
For Each WS In Worksheets
If WS.Name = "BLANK" Then
SheetExists = True
End If
Next WS
If Not SheetExists Then
Sheets.Add
ActiveSheet.Name = "BLANK"
End If
Is there any way to sheets.add silently without bringing focus to or activating the new added sheet? I just want to stay on the sheet (ie. Sheet1) that is currently active and add the new sheet in the background.
Thanks
At first, things look simple but there are a few things to consider:
There could be more sheets selected before running the code
The selected sheet(s) could be Chart sheet(s)
The Workbook can be protected
You might not want to set Application.ScreenUpdating = True at the end of the method because you might be running this from within another method that still needs it off
Restoring selection can only happen if the proper window is activated
You could use this method:
Sub AddWorksheet(ByVal targetBook As Workbook, ByVal sheetname As String)
Const methodName As String = "AddWorksheet"
'Do input checks
If targetBook Is Nothing Then
Err.Raise 91, methodName, "Target Book not set"
ElseIf sheetname = vbNullString Then
Err.Raise 5, methodName, "Sheet name cannot be blank"
ElseIf Len(sheetname) > 31 Then
Err.Raise 5, methodName, "Sheet name cannot exceed 31 characters"
Else
Dim arrForbiddenChars() As Variant
Dim forbiddenChar As Variant
arrForbiddenChars = Array(":", "\", "/", "?", "*", "[", "]")
For Each forbiddenChar In arrForbiddenChars
If InStr(1, sheetname, forbiddenChar) > 0 Then
Err.Raise 5, methodName, "Sheet name cannot contain characters: : \ / ? * [ or ]"
End If
Next forbiddenChar
End If
Dim alreadyExists As Boolean
'Check if a sheet already exists with the desired name
On Error Resume Next
alreadyExists = Not (targetBook.Sheets(sheetname) Is Nothing)
On Error GoTo 0
If alreadyExists Then
MsgBox "A sheet named <" & sheetname & "> already exists!", vbInformation, "Cancelled" 'Can remove
Exit Sub
End If
'Check if Workbook is protected
If targetBook.ProtectStructure Then
'Maybe write code to ask for password and then unprotect
'
'
'Or simply exit
MsgBox "Workbook is protected. Cannot add sheet", vbInformation, "Cancelled"
Exit Sub
End If
Dim bookActiveWindow As Window
Dim appActiveWindow As Window
Dim selectedSheets As Sheets
Dim screenUpdate As Boolean
Dim newWSheet As Worksheet
'Store state
Set bookActiveWindow = targetBook.Windows(1)
Set appActiveWindow = Application.ActiveWindow 'Can be different from the target book window
Set selectedSheets = bookActiveWindow.selectedSheets
screenUpdate = Application.ScreenUpdating
'Do main logic
screenUpdate = False
If bookActiveWindow.Hwnd <> Application.ActiveWindow.Hwnd Then
bookActiveWindow.Activate
End If
If selectedSheets.Count > 1 Then selectedSheets(1).Select Replace:=True
Set newWSheet = targetBook.Worksheets.Add
newWSheet.Name = sheetname
'Restore state
selectedSheets.Select Replace:=True
If appActiveWindow.Hwnd <> Application.ActiveWindow.Hwnd Then
appActiveWindow.Activate
End If
Application.ScreenUpdating = screenUpdate
End Sub
If you want the book containing the code then you can call with:
Sub Test()
AddWorksheet ThisWorkbook, "BLANK"
End Sub
or, if you want the currently active book (assuming you are running this from an add-in) then you can call with:
Sub Test()
AddWorksheet ActiveWorkbook, "BLANK"
End Sub
or any other book depending on your needs.
Just remember who was active:
Sub ytrewq()
Dim wsh As Worksheet, SheetsExist As Boolean
Set wsh = ActiveSheet
Application.ScreenUpdating = False
SheetExists = False
For Each ws In Worksheets
If ws.Name = "BLANK" Then
SheetExists = True
End If
Next ws
If Not SheetExists Then
Sheets.Add
ActiveSheet.Name = "BLANK"
End If
wsh.Activate
Application.ScreenUpdating = False
End Sub
I have the sub "ProtectAllSheets" in Module1 and another one on Sheet1 object, which is meant to delete the whole rows if there is a #REF! Error in column C of Sheet1. It works fine when the sheet is protected... BUT somehow when I close the workbook and open it again(Which is still protected) it doesn't delete the rows with Errors eventhough it is "UserInterface=True". If I unprotect the sheet, it works fine. It seems like as soon as I close the workbook some information is lost "somehow"... I just cannot grasp what the hell could be wrong with the code.
Option Explicit
Public pwd1 As String, pwd2 As String
Sub ProtectAllSheets()
Dim ws As Worksheet
pwd1 = InputBox("Enter your password", "")
If pwd1 = "" Then Exit Sub
pwd2 = InputBox("Enter the password again", "")
If pwd2 = "" Then Exit Sub
'Checks if both the passwords are identical
If InStr(1, pwd2, pwd1, 0) = 0 Or _
InStr(1, pwd1, pwd2, 0) = 0 Then
MsgBox "Please type the same password. ", vbInformation, ""
Exit Sub
End If
For Each ws In ActiveWorkbook.Sheets
If ws.ProtectContents = False = True Then
ws.Protect Password:=pwd1, UserInterFaceOnly:=True
End If
Next ws
MsgBox "Sheets are protected."
End Sub
Option Explicit
Sub Worksheet_Activate()
Dim sh As Worksheet
Dim c As Long
Set sh = ActiveSheet
For c = 400 To 2 Step -1
If IsError(Cells(c, 3)) Then
Rows(c).EntireRow.Delete
End If
Next c
End Sub
Ok Folks, for those of you who may have a similar problem.
I know is not the best solution but it works. It seems like the UserInterFaceOnly feature is not being saved in the file, as soon as you close and reopen the workbook, it is gone. So, this is what I did.
Step 1. Deleted Sub ProtectAllSheets ()
Step 2. Inserted A Workbook_Open procedure.
Now... someone can still see the pasword "1214" if they hit Alt+F11. I just can't do much about it.
Sub Workbook_Open()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
If Not ws.ProtectContents Then
ws.Protect Password:=1214, UserInterFaceOnly:=True
End If
Next ws
MsgBox "Sheets are protected."
End Sub
Step 3. Kept the same Sub by Worksheet_Activate ()
Sub Worksheet_Activate()
Dim sh As Worksheet
Dim c As Long
Set sh = ActiveSheet
For c = 400 To 2 Step -1
If IsError(Cells(c, 3)) Then
Rows(c).EntireRow.Delete
End If
Next c
End Sub
I would like to write a vba code that will not allow to add duplicate sheets with same name. I have a code that is assigned to button on the sheet that is used to change the name of the active sheet.
Sheets are copied from "Main" sheet and hence all the sheets will have button to rename the sheet based on the value selected in the cells A8 and K11 (Both these cells have drop down list with values).
My concern is when user selects the button to rename the sheet, it should look for all the sheets in workbook and display a message if duplicate sheet exists else it should rename the sheet. I am confused in passing values, I am still a starter. Please help
Sub RenameCurrentSheet()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim ws As Worksheet
ThisWorkbook.Unprotect Password:="xyz"
For x = 1 To worksh
If ActiveSheet.Name = "MainSheet" Then
MsgBox "You Cannot Change Name of This Sheet!!!"
Exit For
Else
ActiveSheet.Name = Range("A8").Value & "-" & Range("K11").Value
Exit For
End If
Next x
Application.DisplayAlerts = True
ThisWorkbook.Protect Password:="xyz"
End Sub
To iterate through the worksheets use code like this:
dim wks as Worksheet
for I = 1 to Application.Worksheets.Count
set wks = Application.Worksheets(i)
Debug.Print wks.Name
.... whatever else you want do do
next i
set wks = Nothing ' When done with the object
Just try and reference the worksheet to see if it exists - if it throws an error, then the sheet doesn't exist.
Your code fails as you're always looking at the activesheet, but never changing which sheet is active.
Public Sub CopyAndRenameSheet()
Dim wrkSht As Worksheet
Dim sNewName As String
With ThisWorkbook
'Copy the template to the end of the workbook.
.Worksheets("MainSheet").Copy After:=.Sheets(.Sheets.Count)
'Set reference to last sheet in workbook (the one you've just copied).
Set wrkSht = .Worksheets(.Sheets.Count)
With wrkSht
'Get the new name from the ranges.
sNewName = .Range("A8") & "-" & .Range("K11")
If WorkSheetExists(sNewName) Then
MsgBox "You Cannot Change Name of This Sheet!!!", vbOKOnly + vbCritical
'Do something with the sheet, otherwise you'll be left with a
'sheet called something like "MainSheet (1)".
Application.DisplayAlerts = False
wrkSht.Delete
Application.DisplayAlerts = True
Else
.Unprotect Password:="xyz"
wrkSht.Name = sNewName
.Protect Password:="xyz"
End If
End With
End With
End Sub
Public Function WorkSheetExists(SheetName As String, Optional WrkBk As Workbook) As Boolean
Dim wrkSht As Worksheet
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
On Error Resume Next
Set wrkSht = WrkBk.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
This code copies the name to be assigned from the template instead of the ActiveSheet. If you create the name from the active sheet and make sure that the name meets Excel requirements for sheet names, this code ought to work.
I have done 2 separate prog till now.
One displays a message box before closing a workbook:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim answer As String
Dim question As String
question = "Display all the sheets which are Unprotected"
answer = MsgBox(question, vbYesNo)
If answer = vbNo Then
MsgBox "complete everything and then close"
Cancel = True
Exit Sub
Else
ThisWorkbook.Save
End If
End Sub
Another displays in a new sheet "Unprotected", list of all the unprotected sheets.
Sub UnprotectSheet()
Dim ws As Worksheet, a As Range
ActiveWorkbook.Worksheets.Add.Name = "Unprotected"
For Each ws In ActiveWorkbook.Worksheets
If ws.ProtectContents = False And ws.Name <> "Unprotected" Then
CNT = Sheets("Unprotected").Cells(Sheets("Unprotected").Rows.Count, "A").End(xlUp).Row
Sheets("Unprotected").Cells(CNT + 1, "A") = ws.Name
End If
Next
End Sub
I want a Message box to appear if I try to close the worksheet and if any sheet is unprotected, the message box displays the names of the unprotected sheets. I am facing problem in combining the above 2 codes.
I am not a VBA expert and I am trying it but unable to solve it.
Something like this can show you a list of the unprotected sheets. However, it's probably better to just use VBA to force their protection, rather than prompting the user to do it (unless they need to provide a password for protection status).
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim answer As String
Dim question As String
Dim unprotected as String
unprotected = GetUnprotectedSheets(ThisWorkbook)
If unprotected <> vbNullString Then
MsgBox "Please protected the following worksheets before closing" & vbCRLF & unprotected
Cancel = True
Exit Sub
Else
ThisWorkbook.Save
End If
End Sub
Function GetUnprotectedSheets(wb as Workbook)
'Custom function to return a string of sheet names
' which are unprotected
Dim ret as String
Dim ws as Worksheet
For each ws in wb.Worksheets
If Not ws.ProtectContents Then
ret = IIF(ret = "", ws.Name, ret & vbCRLF & ws.Name)
End If
Next
GetUnprotectedSheets = ret
End Function
You can call a procedure like this to ensure all sheets are protected:
Sub ProtectAllSheets(wb as Workbook)
Dim ws as Worksheet
For each ws in wb.Worksheets
If Not ws.ProtectContents Then ws.Protect
Next
End Sub
Just add a counter to your second script:
Sub UnprotectSheet()
Dim ws As Worksheet, a As Range
Dim iCounter As Integer, strMessage As String 'Adding a counter variable & string
'ActiveWorkbook.Worksheets.Add.Name = "Unprotected"
iCounter = 0 'Initialize it
strMessage = "" 'Initialize empty string for the message box
For Each ws In ActiveWorkbook.Worksheets
If ws.ProtectContents = False Then
iCounter = iCounter + 1 'Keeping track of any unprotected sheet
' CNT = Sheets("Unprotected").Cells(Sheets("Unprotected").Rows.Count, "A").End(xlUp).Row
' Sheets("Unprotected").Cells(CNT + 1, "A") = ws.Name
strMessage = strMessage & ws.Name & " "
End If
Next
' Here you can do your msgbox or any other action if unprotected sheet detected
If iCounter > 0 Then
MsgBox ("These sheets are unprotected: " & strMessage)
End If
End Sub
EDIT:
To enclose that within a button click: add an activeX button to your form, then:
Private Sub CommandButton1_Click()
'E.g. make the sub a commmandbutton_click() event
End Sub
Actually, when you add the button to your form, if you right-click on it you have the option "View code" - this will create an associated Commandbutton_click like I showed above.