Password Protect Viewing for Multiple Worksheets

potatohead

New Member
Joined
Apr 25, 2016
Messages
3
Going off this link, I used the script within, and it works for single sheets. However I need some users to access multiple sheets, and some users to only have access to one. Is there a way to adjust the script to allow for this? I tried the suggestion but am unaware of the FINDNEXT function/how to use it correctly.

Also I need an admin access so they can add/remove usernames as needed.

Can anyone help?

http://www.mrexcel.com/forum/excel-...rd-protect-viewing-individual-worksheets.html
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Going off this link, I used the script within, and it works for single sheets. However I need some users to access multiple sheets, and some users to only have access to one. Is there a way to adjust the script to allow for this? I tried the suggestion but am unaware of the FINDNEXT function/how to use it correctly.

Also I need an admin access so they can add/remove usernames as needed.

Can anyone help?

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
 
Last edited:
Upvote 0
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

thanks it works well! the only issue i have to test out is access from home through the vpn. if it will have the same permissions.
 
Upvote 0
thanks it works well! the only issue i have to test out is access from home through the vpn. if it will have the same permissions.

Glad it helped.

Should work but if username is somehow different, just add it to the list.

Dave
 
Upvote 0
Dave this should work for the most part , from my post on the other thread.. https://www.mrexcel.com/forum/excel...hide-worksheets-based-windows-user-names.html

"What I would like to do is have a worksheet with a list of all Engineer usernames and search that list to see who gets unfettered access. And then once the workbook is complete , Set a flag that changes what Sales people can see.

As an example. Sales opens workbook their username isn't defined and they can only see sheets 1-5, Engineer opens workbook, Their username is defined and they can see sheets 1-10. Engineer processes all the forms, Completes quote then presses a macro button called return to sales .. Sales opens completed workbook and can now see sheets 1-5, 9 and 10.. Sheets 7,8 and 9 are VeryHidden. "

With your solution I have to update with the employee name for every sales person.. over 1000 sales people and they come and go quickly.. Engineers are much more stable and since they are part of my organization I can get the usernames quickly.. So based on the above.. Can I add a wildcard user entry at end of the table, that states if no match open pages 1-5, if match open pages 1-10.. And the ability for after the engineers have finished to set an entry that allows sales to open1-5,9 and 10?

for the wildcard entry all of our usernames are alphanumeric and start with n and followed by 7 numbers.. As an example n0123456

 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,482
Messages
6,113,908
Members
448,532
Latest member
9Kimo3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top