Password Protected Prompt for Cell

[JBIS]

Hi,

I have a spreadsheet we are using for certification by a supervisor. I would like to setup the sheet such that the 'sign off' cells in column (E:E) is password protected. When the supervisor clicks on the 'sign off' cell for a specific project, and changes it to 'Yes'. A prompt box appears that requires the supervisors password. This is to prevent employees from signing off on there behalf.

Any help would be much appreciated.

 

[Jeffrey Mahoney]

So here is a possible solution. The code below needs to be put in the SHEET Module on which the cell SignOff resides. I named the cell SignOff. I created a SETUP sheet and added a list of managers with User Names and Passwords. The list needs to be 2 columns; Column 1 is the User Names for the authorized approvers, the second column needs to be the Passwords for each. You need to create a named range called mnames that encompasses the names. You can call it something different, but you'll need to change the macro below also.

The macro is doing a couple things. Every time the user switches sheets to the sheet with the SignOff cell, it protects the sheet and locks the approval cell. It also is setting the ability for macros to change things on the sheet even though it is protected: UserInterfaceOnly. Any time a user double clicks on the signoff cell, it checks their user name against the list and then compares the entered password to the password on the list for that person.

There's a little macro at the bottom to check somebody's User Name.

Private Sub Worksheet_Activate()
 
  ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True
  Range("SignOff").Locked = True
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim v As Variant
  Dim MgrPW As String
  Dim Cel As Range
  Dim UID As String
  Dim Found As Boolean
  Dim SaveThis As Variant
  Dim CelVal As Variant
 
    'Check if user doubleclicked SignOff Cell
  If Not Intersect(Range("SignOff"), Target) Is Nothing Then
    UID = Application.UserName
    For Each Cel In Sheets("Setup").Range("mnames")           'Check if name is on the list
      CelVal = Cel.Value
      If CelVal <> "" Then
        If UID = CelVal Then
          Found = True
          MgrPW = Cel.Offset(0, 1).Value                    'Save Password
        End If
      Else
        Exit For
      End If
    Next Cel
    If Found = False Then   'User Name not found, ignore them
      Cancel = True
      Exit Sub
    End If
   
    v = InputBox("Please enter your password", "Password")
    If v <> MgrPW Then
      MsgBox "Your password doesn't match"
      Cancel = True
      Exit Sub
    Else
        Range("SignOff").Locked = False               'Unlock Cell for edit
       
    End If
  End If
   
End Sub




Sub GetUID()
  Debug.Print Application.UserName
End Sub

 

[Jeffrey Mahoney]

You may want to change the bottom part of the macro to change the SignOff Cell to YES automatically.

Range("SignOff").Locked = False               'Unlock Cell for edit
Range("SignOff").Value = "Yes"                'Change to YES
Range("SignOff").Locked = True                'Lock Again

 

[JBIS]

Hi Jeffery, thank you for your response and sorry for taking a while to respond back. I've put the code into excel, but it isn't working for me. I'm sure I'm doing something wrong, but cant figure it out. Is there a way I can send you the excel file for review?