Protecting pages from viewing using network username

BlissC

New Member
Joined
Aug 28, 2017
Messages
44
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:

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 Sub

ThisWorkbook:

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
 

Some videos you may like

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,483
Office Version
  1. 2019
Platform
  1. Windows
Hi,
In the workbook open event - try either commenting out the line shown in BOLD & see this does what you want
Or change it to .Protect Password:=shPassword
To make sure that sheet(s) are protected

Rich (BB code):
'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

Dave
 
Solution

BlissC

New Member
Joined
Aug 28, 2017
Messages
44
Hi Dave,

Thanks for your reply. I've tried both the commenting out that line, and changing it to .Protect Password:=shPassword, but with both it was still taking the protection off all the sheets.

On a hunch though I tried in the section just above that changing sh.Unprotect Password:=shPassword to sh.Protect Password:=shPassword. That seems to be working okay for me - it's leaving the sheets protected, but I'm wondering if because of where it is in the code, is it just doing that for admin users, or will it work for all users? (I haven't been able to test it with any of my users yet because they all seem to have logged out early for the day today!)

Rich (BB code):
  '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.Protect 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
                                '.Protect Password:=shPassword
                            End With
                        End If
                    Next c

Thanks,

Bliss
 
Last edited:

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,483
Office Version
  1. 2019
Platform
  1. Windows
Hi,
Code was originally written by me over 5 years ago for another on this site & probably could do with some updating - Code unhides & unprotects sheets for specified users in list but protection state is hard coded - you should be able to change this in the unhide user sheets section of code by replacing UnProtect line with Protect. Admin users were given full access (no protection) but again, you should be able to change this if needed.

At some stage, may re-visit the code & see if can update it to allow Admin to specify Protection status for each user.

Dave
 

BlissC

New Member
Joined
Aug 28, 2017
Messages
44
Aahhh! That makes sense now! (and explains why I couldn't see any difference in the protection state as an Admin user)

Thanks again for your help!

Bliss
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,483
Office Version
  1. 2019
Platform
  1. Windows
Aahhh! That makes sense now! (and explains why I couldn't see any difference in the protection state as an Admin user)

Thanks again for your help!

Bliss

welcome - glad find code helpful

Dave
 

Watch MrExcel Video

Forum statistics

Threads
1,127,504
Messages
5,625,186
Members
416,077
Latest member
SJSB

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
Top