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
Related
I'm currently trying to detect duplicated sheet name using "CheckSheet" function. And I want to call this function to run in "Add Sheet" to prevent users from creating duplicate sheet names. However, I ran into error "Compile Error: Expected function or variable" and still not succeeding in solving the problem. Kindly enlighten me where I am doing it wrong and feel free to point out if there are any weakness and better optimization to my code. Thanks in advance.
Option Explicit
Public sheetName As Variant
Public cS As Variant
Sub CheckSheet(cS) 'To check duplicate sheet name - used in AddSheet function.
Dim wS As Worksheet
Dim wsName As String
wsName = wS(sheetName)
On Error GoTo 0
If wS Is Nothing Then
cS = False
Exit Sub
End Sub
Sub AddSheet()
Dim cSheet As Variant
cSheet = CheckSheet(cS).Value
On Error Resume Next
sheetName = Application.InputBox(prompt:="New Sheet Name", Left:=(Application.Width / 2), Top:=(Application.Height / 2), Title:="Add Sheet", Type:=2)
If sheetName = "" Then
MsgBox "Sheet name cannot be empty!"
Exit Sub
ElseIf cSheet = False Then
MsgBox "Duplicate Name! Please try again!"
Exit Sub
Else
Application.ScreenUpdating = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = sheetName
MsgBox """" & sheetName & """ was successfully created!"
Sheets("Sheet1").Activate
End If
End Sub
Two things.
1. Your code can be simplified. You do not need a function to check if a worksheet exists.
Option Explicit
Sub AddSheet()
Dim sh As Object
Dim sheetName As Variant
'~~> Accept user input
sheetName = Application.InputBox(prompt:="New Sheet Name", _
Left:=(Application.Width / 2), _
Top:=(Application.Height / 2), _
Title:="Add Sheet", Type:=2)
'~~> User presses cancel
If sheetName = False Then Exit Sub
'~~> Check if the sheet name is empty
If sheetName = "" Then
MsgBox "Sheet name cannot be empty!"
Exit Sub
End If
'~~> Check if the sheet exists
On Error Resume Next
Set sh = ThisWorkbook.Sheets(sheetName)
On Error GoTo 0
If Not sh Is Nothing Then
MsgBox "Duplicate Name! Please try again!"
Exit Sub
End If
'~~> Create the worksheet
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = sheetName
MsgBox """" & sheetName & """ was successfully created!"
End With
End Sub
2. Even if you want to use a function, your code has lot of errors. (One of them is pointed out by #braX above.
Is this what you are trying?
Option Explicit
Sub AddSheet()
Dim sheetName As Variant
'~~> Accept user input
sheetName = Application.InputBox(prompt:="New Sheet Name", _
Left:=(Application.Width / 2), _
Top:=(Application.Height / 2), _
Title:="Add Sheet", Type:=2)
'~~> User presses cancel
If sheetName = False Then Exit Sub
'~~> Check if the sheet name is empty
If sheetName = "" Then
MsgBox "Sheet name cannot be empty!"
Exit Sub
End If
'~~> Check if the sheet exists
If DoesSheetExists(CStr(sheetName)) = True Then
MsgBox "Duplicate Name! Please try again!"
Exit Sub
End If
'~~> Create the worksheet
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = sheetName
MsgBox """" & sheetName & """ was successfully created!"
End With
End Sub
'~~> Function to check if sheet exists
Private Function DoesSheetExists(wsName As String) As Boolean
Dim sh As Object
'~~> Check if the sheet exists
On Error Resume Next
Set sh = ThisWorkbook.Sheets(wsName)
On Error GoTo 0
If Not sh Is Nothing Then DoesSheetExists = True
End Function
What I'm trying to do:
If sheets exist that are NOT named "Macro" > prompt user with MsgBox > if yes, delete all sheets not named "Macro"
But only show MsgBox ONCE (do not show MsgBox for each sheet if more than 1 sheet exists)
Problem with current code:
Still getting MsgBox prompt when "Macro" is the only sheet that exists.
Current code:
Sub reset()
Dim conditionMet As Boolean
Dim answer As Integer
conditionMet = FALSE
answer = MsgBox("There Is already data here. Click Yes To delete reset macro.", vbQuestion + vbYesNo)
Application.DisplayAlerts = FALSE
For Each Sheet In ThisWorkbook.Worksheets
If Sheet.Name <> "Macro" Then
conditionMet = TRUE
Else
Exit Sub
End If
Next Sheet
If conditionMet Then
If answer = vbYes Then
Sheet.Delete
Else
Exit Sub
End If
Else
Exit Sub
End If
Application.DisplayAlerts = TRUE
End Sub
Here's one approach:
Const KEEP_THIS As String = "Macro"
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(KEEP_THIS)
On Error GoTo 0
If ws Is Nothing Or ThisWorkbook.Worksheets.Count = 1 Then Exit Sub 'no "Macro" sheet
If MsgBox("Delete all data sheets?", vbQuestion + vbYesNo) <> vbYes Then Exit Sub
'remove all non-Macro sheets
For i = ThisWorkbook.Worksheets.Count To 1 Step -1
With ThisWorkbook.Worksheets(i)
If .Name <> KEEP_THIS Then .Delete
End With
Next i
Delete All Sheets Except a Specified One
The following shows how to avoid a few (less) common surprises.
The Code
Option Explicit
Sub resetWorkbook()
Const SheetName As String = "Macro"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' There has to be at least one sheet in the workbook.
If wb.Sheets.Count = 1 Then Exit Sub
' Check for existence.
On Error Resume Next
Dim sh As Object: Set sh = wb.Sheets(SheetName)
On Error GoTo 0
If sh Is Nothing Then Exit Sub
If MsgBox("There Is already data here. Click Yes To delete reset macro.", _
vbQuestion + vbYesNo) = vbNo Then Exit Sub
' An only sheet in a workbook has to be visible.
If Not sh.Visible = xlSheetVisible Then
sh.Visible = xlSheetVisible
End If
' Write the other sheet names to an array.
Dim SheetNames() As String: ReDim SheetNames(1 To wb.Sheets.Count - 1)
Dim n As Long
For Each sh In wb.Sheets
' Allow case-insensitivity i.e. A = a.
If StrComp(sh.Name, SheetName, vbTextCompare) <> 0 Then
n = n + 1
SheetNames(n) = sh.Name
End If
Next sh
' Delete sheets in one go with no pop-ups.
Application.DisplayAlerts = False
wb.Sheets(SheetNames).Delete
Application.DisplayAlerts = True
' Inform.
MsgBox "Number of sheets deleted: " & n, vbInformation, "Success"
End Sub
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
Working on a macro that will go to the first sheet. I was using:
Sub GoToFirstSheet()
On Error Resume Next
Sheets(1).Select
End Sub
However, if sheet 1 is hidden, this wont work. How can I incorporate a way to go to the first sheet that isn't hidden?
Something like this?
Option Explicit
Sub GoToFirstSheet()
Dim i As Long
For i = 1 To ThisWorkbook.Sheets.Count
On Error Resume Next
Sheets(i).Activate
If Err.Number = 0 Then Exit For
Next i
End Sub
This should do it:
Option Explicit
Sub GoToFirstSheet()
Dim ws As Worksheet 'declare a worksheet variable
'loop through all the worksheets in the workbook
For Each ws In ThisWorkbook.Worksheets
'If the sheet is not hidden
If ws.Visible = xlSheetVisible Then
ws.Select 'select it
Exit For 'exit the loop
End If
Next ws
End Sub
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.