CODEWITHSUNDEEP
excelvba
Chadi N
Chadi N

Reputation: 441

How to restric workbook to specific users

I would like to have an excel worksheet, where I can enter the users name to grant them access to the excel workbook.

I found the VBA code, and it's fine, but I need to have it on a worksheet. I think it's more practical that way than having to enter the vba code to make changes (changing users or adding users).

Here is the code:

Private Sub Workbook_Open()
Dim user As String
Dim users(5) As String

users(0) = "SomeUser"
users(1) = "SomeUser"
users(2) = "SomeUser"
users(3) = "SomeUser"
users(4) = "SomeUser"

user = Application.UserName

Dim access As Boolean
Dim i As Integer

access = False

For i = 0 To 4
    If users(i) = user Then
        access = True
        Exit For
    End If
Next

If access = False Then
    MsgBox ("Sorry, the user """ & "Liam" & """ does not have the correct access rights to view this workbook")
    ActiveWorkbook.Close
End If

End Sub

Upvotes: 0

Views: 51

Answers (1)

Ryan Wildry
Ryan Wildry

Reputation: 5677

This will do what you are after, but there are better ways to manage access rights in Excel files.

Place this code in the ThisWorkbook object

Private Sub Workbook_Open()
    Dim Users As Object
    Set Users = GetUsers()

    If Not Users.Exists(Application.UserName) Then
        MsgBox "Sorry, you lack access to this workbook.", vbCritical, "No Access"
        ThisWorkbook.Close
    End If
End Sub

Place this code in a Module. It assumes you have a sheet named Users, with UserNames being stored starting on cell A2 going down.

Public Function GetUsers() As Object
    Dim Users As Range
    Dim User  As Range

    With ThisWorkbook.Sheets("Users") 'Replace Users with name, or use CodeName
        Set Users = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row) 'Assuming header row on A1
    End With

    Set GetUsers = CreateObject("Scripting.Dictionary")

    For Each User In Users
        If Not GetUsers.Exists(User.Value2) Then GetUsers.Add User.Value2, User.Value2
    Next
End Function

Upvotes: 1

Related Questions