VBA Express : Excel - Selectively permit access to spreadsheet through choice of password.

Excel

Selectively permit access to spreadsheet through choice of password.

Ease of Use

Intermediate

Version tested with

2003

Submitted by:

mdmackillop

Description:

By entering one of a number of passwords, different users will be permitted access to change designated cells.

Discussion:

Permit Sales. Pricing or Management each to have access to adjust Quantity, Pricing or Discount on an escalating level of permissions.

Code:

instructions for use

			Option Explicit 
Option Compare Text 
 
Dim MyRange1 As Range, MyRange2 As Range, MyRange3 As Range 
Dim AllRange As Range 
Dim Pass1 As String 
Dim Pass2 As String 
Dim Pass3 As String 
 'Dim additional passwords as required
 
 '***********************************
 'Management password; gives access to all cells
Dim PassAll As String 
 
 'Set the spreadsheet password
Const Pwd = "test" 
 
Private Sub SetRanges() 
     
     'Set password and permitted ranges for each user
    Pass1 = "Yes1" 
    Set MyRange1 = Union([B8], [B10], [B12]) 
     
    Pass2 = "Yes2" 
    Set MyRange2 = Union([B8], [B10], [B12], [D8], [D10], [D12]) 
     
    Pass3 = "Yes3" 
    Set MyRange3 = Union([F8], [F10], [F12]) 
     
     'Add further Passwords and Ranges as required
     
     
     '*************************************
    PassAll = "Yes99" 
    Set AllRange = Union(MyRange1, MyRange2, MyRange3) 
     
End Sub 
 
 
Private Sub Worksheet_Activate() 
    TextBox1 = "" 
    TextBox1.Activate 
End Sub 
 
 
Sub UnprotectCell(MyRange As Range) 
     'Unlocks cells according to range
    ActiveSheet.Unprotect Password:=Pwd 
    MyRange.Locked = False 
    MyRange.Interior.ColorIndex = 4 'Comment out if not required
    ActiveSheet.Protect Password:=Pwd 
     
End Sub 
 
Sub ProtectCell() 
     'Locks all specified unlocked cells
    ActiveSheet.Unprotect Password:=Pwd 
    AllRange.Locked = True 
    AllRange.Interior.ColorIndex = 8 'Comment out if not required
    ActiveSheet.Protect Password:=Pwd 
     
End Sub 
 
Private Sub TextBox1_Change() 
    SetRanges 
    Select Case TextBox1 
         'Protects all cells then unprotects permitted ones
    Case Is = Pass1 
        ProtectCell 
        UnprotectCell MyRange1 
        CleanUp 
    Case Is = Pass2 
        ProtectCell 
        UnprotectCell MyRange2 
        CleanUp 
    Case Is = Pass3 
        ProtectCell 
        UnprotectCell MyRange3 
        CleanUp 
         'Add in further permissions as required
         
         
         '*************************
    Case Is = PassAll 
        ProtectCell 
        UnprotectCell AllRange 
        CleanUp 
    Case Else 
        ProtectCell 
        CleanUp 
    End Select 
     
End Sub 
 
Sub CleanUp() 
    Set MyRange1 = Nothing 
    Set MyRange2 = Nothing 
    Set MyRange3 = Nothing 
     'Add in ranges as required
     
     
     '*********************************
    Set AllRange = Nothing 
End Sub 
 
Sub LockIt() 
    TextBox1 = "" 
End Sub

How to use:

Enter the code in the appropriate worksheet module.
Add a TextBox to the spreadsheet; set background colour and Password character as desired.
Set the User ranges and individual passwords to suit
Reset the worksheet password
Delete Option Compare Text if you want case sensitive passwords

Test the code:

Open the sample workbook
Enter Yes1, Yes2, Yes3 or Yes99 (case is not important) in the yellow Textbox; each will permit different access to the designated cells. NOTE: You should click into the textbox, as scrolling takes you into the underlying cell.
Clearing or entering an invalid password will lock all cells.

Sample File:

Unprotects.zip 13.66KB

Approved by mdmackillop

This entry has been viewed 577 times.