vba to request a password for multiply dropdown list entries

[DC195]

Hi,

I have a vba code found on a previous thread which adds passwords to a drop down list, (Link to original post is included below). The vba works really well with my project with the drop down on sheet 1 and the passwords on sheet 2. Can this vba be used to handle multiply drop downs on sheet 1 sourcing from the same data on sheet 2 ??

I've tried to adapt the vba code myself but have very limited skills when coding and no surprise nothing but errors.

Any help would be greatly appreciated.

vba to request a password for dropdown list entries

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...

www.mrexcel.com

 

[DC195]

Here's the vba in text if anybody wants a play.

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("C").SpecialCells(xlCellTypeAllValidation)
  Set rChanged = Intersect(Target, rDV)
  If Not rChanged Is Nothing Then
    Application.EnableEvents = False
    With Sheets("Sheet2")
      Set rDVChoices = .Range("A1", .Range("A1").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

 

[Peter_SSs]

Welcome to the MrExcel board!

Here's the vba in text if anybody wants a play.

That is much better than a picture of it but when posting vba code in the forum, please use the available code tags. It makes the code much easier to read/debug & copy. My signature block below has more details. I have added the tags for you this time.

 

[DC195]

Welcome to the MrExcel board!


That is much better than a picture of it but when posting vba code in the forum, please use the available code tags. It makes the code much easier to read/debug & copy. My signature block below has more details. I have added the tags for you this time.

Thank you for your assistance and thank you for the welcome. I'm very much still learning the ropes.

 

[DC195]

Not Sure if this the best way to resolve it but it works.

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("C").SpecialCells(xlCellTypeAllValidation)
  Set rChanged = Intersect(Target, rDV)
  If Not rChanged Is Nothing Then
    Application.EnableEvents = False
    With Sheets("Sheet2")
      Set rDVChoices = .Range("A1", .Range("A1").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
   On Error GoTo Cleanup
  Set rDV = Columns("E").SpecialCells(xlCellTypeAllValidation)
  Set rChanged = Intersect(Target, rDV)
  If Not rChanged Is Nothing Then
    Application.EnableEvents = False
    With Sheets("Sheet2")
      Set rDVChoices = .Range("A1", .Range("A1").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
  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("Sheet2")
      Set rDVChoices = .Range("A1", .Range("A1").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
  Set rDV = Columns("I").SpecialCells(xlCellTypeAllValidation)
  Set rChanged = Intersect(Target, rDV)
  If Not rChanged Is Nothing Then
    Application.EnableEvents = False
    With Sheets("Sheet2")
      Set rDVChoices = .Range("A1", .Range("A1").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