Vlookup Environ ("username") to get proper name and allocate protection

Hi NickMax1,

as I was not sure which table should be protected the macro will protect sheet1 only. In case you would like to protect the "users" worksheet, you could simply replace sheet1 by users.

Please regard that the accesslevels (as defined in column C of the users spreadsheet, would need to be spelled exactly as you have mentioned it below ( "Full access (ie edit, delete rows etc)", "Full access but no deletion capability" , "Autofilter access, edit access, no delete ability" ) otherwise the macro would set the level to "read only access" to makes sure!

The macro should not be pasted into a module, but should be put directly into "ThisWorkbook" to ensure that it will run when the file is opened. For your reference I have attached a testfile

Option Explicit
Const PW = "YourPassword"

Private Sub Workbook_Open()
    Dim AccLevel As String
    Dim FullName As String
    Dim x As Integer

    On Error Resume Next
    x = Application.Match(Application.UserName, Worksheets("Users").Columns("A"), 0)
    If IsNumeric(x) And x > 0 Then    'if user was found
        AccLevel = Worksheets("Users").Cells(x, 3)
        FullName = Worksheets("Users").Cells(x, 2)
    Else 'if username was not found
        AccLevel = "Read only Access"
    End If
    Select Case AccLevel
    Case "Full access (ie edit, delete rows etc)"
        Worksheets("Sheet1").Unprotect Password:=PW

    Case "Full access but no deletion capability"
        Worksheets("Sheet1").Protect Password:=PW, DrawingObjects:=False, Contents:=True, Scenarios:= _
                                     False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
                                     AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
                                                                                           :=True, AllowInsertingHyperlinks:=True, AllowSorting:=True, _
                                     AllowFiltering:=True, AllowUsingPivotTables:=True

    Case "Autofilter access, edit access, no delete ability"
        Worksheets("Sheet1").Protect Password:=PW, DrawingObjects:=True, Contents:=True, Scenarios:=True _
                                   , AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True

    Case Else
        AccLevel = "Read only Access"
        FullName = "Guest " & (Application.UserName)
        Worksheets("Sheet1").Protect Password:=PW, DrawingObjects:=True, Contents:=True, Scenarios:=True
    End Select

    MsgBox "Welcome " & FullName & " you have " & AccLevel, Title:="Welcome"
End Sub

In case you would require additional access levels. you could simply record a "manual protection" and adjust the code accordingly.
Hope it works as expected

Regards

Theo

Hi nickmax,

sorry for not replying any earlier, but I was not online. Try this:

Option Explicit
Const PW = "YourPassword"

Private Sub Workbook_Open()
    Dim AccLevel As String
    Dim FullName As String
    Dim x As Integer
    Dim ws As Worksheet

    On Error Resume Next
    x = Application.Match(Application.UserName, Worksheets("Users").Columns("A"), 0)
    If IsNumeric(x) And x > 0 Then    'if user was found
        AccLevel = Worksheets("Users").Cells(x, 3)
        FullName = Worksheets("Users").Cells(x, 2)
    Else    'if username was not found
        AccLevel = "Read only Access"
    End If
    Select Case AccLevel
    Case "Full access (ie edit, delete rows etc)"
        For Each ws In ThisWorkbook.Worksheets
            ws.Unprotect Password:=PW
        Next
    Case "Full access but no deletion capability"
        For Each ws In ThisWorkbook.Worksheets
            ws.Protect Password:=PW, DrawingObjects:=False, Contents:=True, Scenarios:= _
                       False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
                       AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
                                                                             :=True, AllowInsertingHyperlinks:=True, AllowSorting:=True, _
                       AllowFiltering:=True, AllowUsingPivotTables:=True
        Next
    Case "Autofilter access, edit access, no delete ability"
        For Each ws In ThisWorkbook.Worksheets
            ws.Protect Password:=PW, DrawingObjects:=True, Contents:=True, Scenarios:=True _
                     , AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
        Next
    Case Else
        AccLevel = "Read only Access"
        FullName = "Guest " & (Application.UserName)
        For Each ws In ThisWorkbook.Worksheets
            ws.Protect Password:=PW, DrawingObjects:=True, Contents:=True, Scenarios:=True
        Next
    End Select

    MsgBox "Welcome " & FullName & " you have " & AccLevel, Title:="Welcome"
End Sub

Just change your environ routine as you did before and it should work


Regards

Theo

works brilliantly!

solved