have macros complete and enter passwords for sheet protection.

[Guest]

many of my sheets are used by people seemingly with a mission to destroy them
in every way possible. hence high level of security applied sheet by sheet -
to put it in context I am entering the password 3x (1 on unprotect, 2 on
protect) 2x per week 50x sheets - so 300 times per week - but I cant figure
programming as part of macro so it will auto fill these for me - the
rationale being the macro itself would be password protected to get the same
security in 2 mouse clicks instead of 300 keyboard entries.

 

[Jim Cone]

"nick-ipswich",

The following code consists of two separate subs.
One to protect all sheets and one to unprotect all sheets.

It is set up so that if the workbook name and the user
name agree with names in the code then the password will be used.
Otherwise, no password is used when protecting/unprotecting the workbook.

'This entire page of code should be copied and pasted into the personal.xls file.
'NOTE: Replace the text referring to InsertWorkbookNameHere, InsertUserNameHere,
' and InsertPasswordHere with the actual names/password.
The quote marks should remain.

Regards,
Jim Cone
San Francisco, USA


'----------------------------------------------------------------------------------------
' Jim Cone did it.
'----------------------------------------------------------------------------------------
Sub LockEverySheet()
On Error GoTo NotSecure
Dim Sht As Object
Application.ScreenUpdating = False
If ActiveWorkbook.Name = "InsertWorkbookNameHere.xls" Then
If Application.UserName = "InsertUserNameHere" Then
For Each Sht In ActiveWorkbook.Sheets
Sht.Protect "InsertPasswordHere", True, True, True, True
Next 'Sht
Application.ScreenUpdating = True
Application.Cursor = xlDefault
MsgBox ActiveWorkbook.Name & " sheets locked. ", vbInformation, " Lock Sheets"
End If
Else
For Each Sht In ActiveWorkbook.Sheets
Sht.Protect
Next 'Sht
Application.ScreenUpdating = True
Application.Cursor = xlDefault
MsgBox "All sheets locked. ", vbInformation, " Lock Sheets"
End If
Set Sht = Nothing
Exit Sub

NotSecure:
Beep
Set Sht = Nothing
Application.ScreenUpdating = True
MsgBox "Error " & Err.Number & " " & Err.Description, vbCritical, " Lock Sheets"
End Sub

'----------------------------------------------------------------------------------------
' Jim Cone did it.
'----------------------------------------------------------------------------------------
Sub UnlockEverySheet()
On Error GoTo StillLocked
Dim Sht As Object

Application.ScreenUpdating = False
If ActiveWorkbook.Name = "InsertWorkbookNameHere.xls" Then
If Application.UserName = "InsertUserNameHere" Then
For Each Sht In ActiveWorkbook.Sheets
Sht.Unprotect "InsertPasswordHere"
Next 'Sht
Application.ScreenUpdating = True
Application.Cursor = xlDefault
MsgBox ActiveWorkbook.Name & " sheets unlocked. ", vbInformation, " UnLock Sheets"
End If
Else
For Each Sht In ActiveWorkbook.Sheets
On Error Resume Next
Sht.Unprotect
On Error GoTo StillLocked
If Sht.ProtectContents Then
Sht.Activate
Application.ScreenUpdating = True
Application.Cursor = xlDefault
MsgBox "Unable to unlock sheet """ & Sht.Name & """ " & vbCr & _
"Exiting program.", vbOKOnly + vbExclamation, " Unlock Sheets"
Set Sht = Nothing
Exit Sub
End If
Next 'Sht
Application.ScreenUpdating = True
Application.Cursor = xlDefault
MsgBox "All sheets unlocked. ", 64, " Unlock Sheets"
End If
Set Sht = Nothing
Exit Sub

StillLocked:
Beep
Set Sht = Nothing
Application.ScreenUpdating = True
MsgBox "Error " & Err.Number & " " & Err.Description, vbCritical, " Unlock Sheets"
End Sub
'---------------------------------------------------------------------------------------