Protecting pages from viewing using network username

BlissC

New Member
Joined
Aug 28, 2017
Messages
47
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
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
 

danjuma

Board Regular
Joined
Sep 21, 2008
Messages
248
I didn't, but I have now created a sheet named "Home", and that seems to have solved the problem. Many thanks and most grateful. Just to clarify a couple of things with you:
(1) As Admin (i.e. TRUE in the Admin column against my username), I can see all the sheets in the workbook, but no one else can, except the sheet(s) they have 'X' against their names, correct?
(2) I have changed .Unprotect Password:=shPassword in 'unhide user sheets to .Protect Password:=shPassword to ensure sheets are protected to all apart from Admin. Is this correct? Also, the workbook opens for me with all sheets unprotected as Admin, I am assuming when I close the workbook, all sheets become protected again, so that when opened by someone else without Admin rights, all sheets remain protected, correct?

Thanks
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,850
Office Version
  1. 2019
Platform
  1. Windows
Hi,
glad resolved

1 - correct that is the intention of the code
2 - is a slight change from original code but if works for your use then all ok
3 - HideSheets code should protect sheets when workbook closed & saved

Dave
 

danjuma

Board Regular
Joined
Sep 21, 2008
Messages
248
Hi,
glad resolved

1 - correct that is the intention of the code
2 - is a slight change from original code but if works for your use then all ok
3 - HideSheets code should protect sheets when workbook closed & saved

Dave
Many thanks!
 

danjuma

Board Regular
Joined
Sep 21, 2008
Messages
248
Hi dmt32, I am sorry to bother you again. Unfortunately, the workbook does not appear to work when uploaded to a shared drive on my work network. The workbook opens, but only displays the 'Home' page. nothing else. It's like there are no usernames being processed at all (I mean, checking username of person logged onto PC/network and open the correct sheet for the username)
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,850
Office Version
  1. 2019
Platform
  1. Windows
I would check the names listed in the table match those on the network & if still having issues, consult with your IT people

Dave
 

danjuma

Board Regular
Joined
Sep 21, 2008
Messages
248
Okay. Will do that. Many thanks for your assistance and much appreciated!
 

Forum statistics

Threads
1,144,424
Messages
5,724,249
Members
422,542
Latest member
jedidia

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