Hi, welcome to the board.
A better way to manage your requirement is via a table with user’s names & sheets they have access to. Login would be automatic (no passwords needed) as you would check valid users against their network Username.
The following solution my seem a little daunting but should manage everything for you with minimal maintenance on your part
Place ALL following code in a STANDARD module:
Rich (BB 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 Sub
I have called the sheet that is to remain visible “Home” but where shown in RED, you must change as required.
Place ALL following code in the ThisworkBook module code page:
Rich (BB 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
When all done, save & close workbook then re-open. You should see new tab “User List”
In Row 2:
Col A your network UserName
Column B TRUE for admin user
In Row 1 Column 3 onward:
All other worksheet names should be listed.
All you need do is Add all the network user names in Column A as required
Then under each column, place an X for each sheet you want to give each user access to.
Column B you can leave blank unless you want another to be an Admin user in which case enter TRUE
When your users open your workbook, they should only see the worksheets you have set for them.
If you add other worksheets, these will be added to the table when you activate it (select it)
You just need to update Users & table as required, there should be no need to make adjustments to any of the code.
solution is not fool proof but hopefully, will do what you want.
Dave
