Hi everyone,
I'm using this VBA script from the 3rd post on this thread: Password Protect Viewing for Multiple Worksheets (code below) to control access to different pages in my workbook, which uses the network username to control who gets to see what, and the script itself is working fine. There's just one problem though - every time it runs (i.e. each time the workbook's opened), it removes the sheet protection on each sheet (i.e. via 'Protect Sheet') which prevents any of the formulas from being accidentally overwritten. With the same password on all pages, it just unlocks them all!
I've also tried just putting the password that you specify in the code at the start of the code in the standard module just on the HomeSheet page and the Userlist table tab it creates, and giving all the other sheets a different password, but when I do that, all it opens is the HomeSheet tab.
I'm really pleased it works to control access to the pages, but with the protection removed from the sheets, knowing that some of my users suffer from "fat fingers" and accidentally hit keys they don't mean to on a regular basis, I fear that I'm going to be having to constantly go into the workbook to fix cells where someone's overwritten a formula.
Does anyone know how I can either get it to stop removing the sheet protection, or get it to re-apply the protection once it's opened please?
Thanks,
Bliss
Standard module:
ThisWorkbook:
I'm using this VBA script from the 3rd post on this thread: Password Protect Viewing for Multiple Worksheets (code below) to control access to different pages in my workbook, which uses the network username to control who gets to see what, and the script itself is working fine. There's just one problem though - every time it runs (i.e. each time the workbook's opened), it removes the sheet protection on each sheet (i.e. via 'Protect Sheet') which prevents any of the formulas from being accidentally overwritten. With the same password on all pages, it just unlocks them all!
I've also tried just putting the password that you specify in the code at the start of the code in the standard module just on the HomeSheet page and the Userlist table tab it creates, and giving all the other sheets a different password, but when I do that, all it opens is the HomeSheet tab.
I'm really pleased it works to control access to the pages, but with the protection removed from the sheets, knowing that some of my users suffer from "fat fingers" and accidentally hit keys they don't mean to on a regular basis, I fear that I'm going to be having to constantly go into the workbook to fix cells where someone's overwritten a formula.
Does anyone know how I can either get it to stop removing the sheet protection, or get it to re-apply the protection once it's opened please?
Thanks,
Bliss
Standard module:
VBA Code:
'add password as required
Public Const shPassword As String = ""
'change Main sheet name as required
Public Const HomeSheet As String = "Home"
Function IsValidUser(ByRef Target As Range, ByRef Admin As Boolean) As Boolean
'function looks for valid username in user list worksheet
Dim FindCell As Range
Set FindCell = Target.Find(Environ("USERNAME"), LookIn:=xlValues, lookat:=xlWhole)
If Not FindCell Is Nothing Then
Admin = FindCell.Offset(0, 1)
Set Target = FindCell
IsValidUser = True
End If
End Function
Sub BuildTable(ByVal ws As Object)
'builds table of all worksheets available in workbook
'table is updated if new sheets are added when activated
'by an admin user.
Dim sh As Worksheet
Dim LastCol As Long
Dim m As Variant
With ws
.Unprotect Password:=shPassword
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
End With
'add sheet names to row 1
For Each sh In Worksheets
Select Case sh.Name
Case HomeSheet, "User List"
Case Else
On Error Resume Next
m = Application.Match(sh.Name, ws.Cells(1, 1).Resize(1, LastCol), False)
If IsError(m) Then ws.Cells(1, LastCol).Value = sh.Name: LastCol = LastCol + 1
End Select
Next
End Sub
Function UserTable(ByVal SheetName As String) As Worksheet
'Function sets object reference to User List worksheet
'if it does not exist it is added
On Error Resume Next
Set UserTable = ThisWorkbook.Worksheets(SheetName)
If UserTable Is Nothing Then
Application.ScreenUpdating = False
Set UserTable = Worksheets.Add(after:=Worksheets(1))
With UserTable
.Name = "User List"
.Range("A1:B1").Value = Array("User Name", "Admin")
.Columns(1).ColumnWidth = 15
.Columns(2).ColumnWidth = 8
.Range("A2").Value = Environ("USERNAME")
.Range("B2").Value = True
End With
'build table
BuildTable ws:=UserTable
End If
On Error GoTo 0
End Function
Sub HideSheets()
Dim sh As Worksheet
For Each sh In ThisWorkbook.Worksheets
If sh.Name = HomeSheet Then
'do nothing
Else
sh.Visible = xlSheetVeryHidden
If Len(shPassword) > 0 Then sh.Protect Password:=shPassword
End If
Next sh
End SubThisWorkbook:
VBA Code:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
HideSheets
End Sub
Private Sub Workbook_Open()
Dim Admin As Boolean
Dim msg As Variant
Dim LastCol As Integer, c As Integer
Dim rng As Range
Dim sh As Worksheet, UserList As Worksheet
On Error GoTo myerror
ThisWorkbook.Sheets(HomeSheet).Visible = xlSheetVisible
HideSheets
Set UserList = UserTable("User List")
With UserList
.Unprotect Password:=shPassword
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rng = .Range("A2:A" & lastrow)
End With
'check valid user
If IsValidUser(rng, Admin) Then
Application.ScreenUpdating = False
'Admin User unhide all sheets
If Admin Then
For Each sh In ThisWorkbook.Worksheets
sh.Visible = xlSheetVisible
sh.Unprotect Password:=shPassword
Next sh
Else
'unhide user sheets
With UserList
For c = 3 To LastCol
If UCase(.Cells(rng.Row, c).Value) = "X" Then
With Sheets(.Cells(1, c).Value)
.Visible = xlSheetVisible
.Unprotect Password:=shPassword
End With
End If
Next c
If Len(shPassword) > 0 Then .Protect Password:=shPassword
End With
End If
'activate home sheet
Worksheets(HomeSheet).Activate
Else
'user not valid
If Len(shPassword) > 0 Then UserList.Protect Password:=shPassword
MsgBox "You Do Not Have Access To This File", 16, "Access Invalid"
ThisWorkbook.Close False
End If
myerror:
Application.ScreenUpdating = True
If Err > 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub
Private Sub Workbook_SheetActivate(ByVal sh As Object)
If sh.Name = "User List" Then BuildTable ws:=sh
End Sub
