vba to request a password for dropdown list entries

[cjcass]

Hi,
I'm looking for a macro/vba that will require a user to enter a password before they can enter a selection from a dropdown list. In the example below the range C5:C10 is named 'Fruit'. The dropdowns to select from the range 'Fruit' are located in G5:G8 but ultimately may end up on another wksheet. So when a user selects, say 'Grape', from a cell dropdown they are prompted for a password. The vba looks up the user's password entry against the list in D5:D10 and if it's correct the selection is allowed, if the password is not correct the user receives an 'incorrect password' message and the cell is left blank. Please note that my 'Fruit' and Password ranges will be bigger than the example and may well change so I need some kind of 'lookup' feature in the vba as opposed to entering all the fruit and passwords into the code. If the the code could also allow the these two ranges to be dynamic in size (number of rows down) then even better!
Any help on this would be much appreciated.
Many thanks.

 

[Peter_SSs]

See if this Worksheet_Change code does what you want.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rDV As Range, rDVChoices As Range, rChanged As Range, rCell As Range
  Dim sPWord As String, sErrors As String
  
  Set rDV = Columns("G").SpecialCells(xlCellTypeAllValidation)
  Set rChanged = Intersect(Target, rDV)
  If Not rChanged Is Nothing Then
    Application.EnableEvents = False
    Set rDVChoices = Range("C5", Range("C5").End(xlDown))
    For Each rCell In rChanged
      If Len(rCell.Value) > 0 Then
        sPWord = InputBox(Prompt:="Enter password for " & rCell.Value)
        If sPWord <> rDVChoices.Find(What:=rCell.Value, MatchCase:=False).Offset(, 1).Value Then
          sErrors = sErrors & vbLf & rCell.Value & "(" & rCell.Address(0, 0) & ")"
          rCell.ClearContents
        End If
      End If
    Next rCell
    Application.EnableEvents = True
    If Len(sErrors) > 0 Then MsgBox "Incorrect password(s) for:" & sErrors, vbOKOnly
  End If
End Sub

 

[cjcass]

Hi,
That works great thanks, just one follow query up if I may - what would the code be if the 'Fruit and Passwords' were on Sheet1 and the Dropdowns were on Sheet2?
Thanks again.

 

[cjcass]

Hi,
One thing I've noticed is that if this code goes into an error for whatever reason it then no longer works unless the file is closed and then re-opened...
Rgds,

 

[cjcass]

Have now put an errorhandler in to deal with any errors

 

[cjcass]

Errorhandler not working...

 

[Peter_SSs]

One thing I've noticed is that if this code goes into an error for whatever reason it then no longer works unless the file is closed and then re-opened..

If an error occurs after Application.EnableEvents = False then events will be disabled. Closing & reopening Excel is one way to reset that. It would be good to know what is causing any errors in the code as it might mean there are other issues with it or the data to be addressed rather than just getting out of the code.

what would the code be if the 'Fruit and Passwords' were on Sheet1 and the Dropdowns were on Sheet2?

Assuming the fruit & passwords are still in C5:Dn in Sheet1 and the DV cells in Sheet2 are still in column G, then try this code in the Sheet2 module (remove the previous Sheet1 module code)

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rDV As Range, rDVChoices As Range, rChanged As Range, rCell As Range
  Dim sPWord As String, sErrors As String
  
  On Error GoTo Cleanup
  Set rDV = Columns("G").SpecialCells(xlCellTypeAllValidation)
  Set rChanged = Intersect(Target, rDV)
  If Not rChanged Is Nothing Then
    Application.EnableEvents = False
    With Sheets("Sheet1")
      Set rDVChoices = .Range("C5", .Range("C5").End(xlDown))
    End With
    For Each rCell In rChanged
      If Len(rCell.Value) > 0 Then
        sPWord = InputBox(Prompt:="Enter password for " & rCell.Value)
        If sPWord <> rDVChoices.Find(What:=rCell.Value, MatchCase:=False).Offset(, 1).Value Then
          sErrors = sErrors & vbLf & rCell.Value & "(" & rCell.Address(0, 0) & ")"
          rCell.ClearContents
        End If
      End If
    Next rCell
    If Len(sErrors) > 0 Then MsgBox "Incorrect password(s) for:" & sErrors, vbOKOnly
  End If
Cleanup:
  Application.EnableEvents = True
End Sub

 

[cjcass]

Thanks for coming back Peter.
I now see what you mean re. errors occurring after Application.EnableEvents = False (I should've spotted this!). I tried changing the code myself to recognise the different wksheets, alas to no avail, but your revised code works perfectly!
Thanks again for your time and help with this, much appreciated

 

[Peter_SSs]

You're welcome. Glad it is going for you now. Thanks for the follow-up.

 

[cjcass]

Hello again,

Is there a way to mask the password when the user is entering it?

On searching the web it would appear that an inputbox cannot masks characters?... and it's recommended to use an textbox in a userform and let its property "PasswordChar" be equal to *. Can this be achieved by making some changes to the above code? (it's a bit beyond me!)

Any help much appreciated.

Regards.