Multiple Password Linked to Combo Box

[tlc53]

Hi there,

I currently have a Combo Box that when a name is selected from the dropdown option, a password is requested. If the correct password is entered (12345) the date will be entered in the corresponding cell.

However, it is not quite working right. Currently it is one password for all. If I select Sarah Bing enter password, the date is added but then if I select John Doe, cancel/don't enter password, if will leave the date from the first selection but the name will change to John Doe. Thus, making it look like John Doe was responsible for entering the date when really is was Sarah Bing.

Here's an example of the dropdown options;

Please Select
Sarah Bing
John Doe
Mary Jane

I would like Please Select to be the default name, especially when a password is not entered.
I would like each user/name to have their own password
Instead of the corresponding cell just entering the date, I would like the user initials plus date. Eg. SB 20/11/18

Here's the code that I currently have;

Sub PutDateWithPW()
If Application.InputBox("Enter Password to Authorise Accounts", Default:="") = "12345" Then
Range("Q7").Value = Date
End If
'With ActiveSheet.Shapes(Application.Caller).ControlFormat
' .Value = IIf(.Value = xlON, xlOff, xlOn)
'End With
End Sub


Sub PutDateWithPW1()
If Application.InputBox("Enter Password to Authorise Accounts", Default:="") = "12345" Then
Range("Q8:Q9").Value = Date
End If
'With ActiveSheet.Shapes(Application.Caller).ControlFormat
' .Value = IIf(.Value = xlON, xlOff, xlOn)
'End With
End Sub

What I am trying to achieve is for the sheet to be marked with who is authorising the work/spreadsheet and for it to be protected against unauthorised changes.

Hopefully someone can help. Thanks for your time!

 

[Jaafar Tribak]

@tlc53

Here is an update of the above code which works for two comboboxes as requested .. The first combobox puts a date stamp in the Cell Q7 and the second in the merged cells Q8:Q9 as requested.

The code assumes that both comboboxes are populated with the same group of people ie: same usernames

The code also lockes the Date Stamp cells so they can only be edited after selecting the user name from the combobox and entering the correct respective password.

Workbook Sample

Code in the ThisWorkbook Module:

Option Explicit

[B][COLOR=#008000]'**************************************************************[/COLOR][/B]
'UserNames and their respective passwords ... Change as needed.
Private Const USER_NAMES_1 = "Sarah Bing,John Doe,Mary Jane"
Private Const USER_NAMES_1_PASSWORDS = "AAAA,BBBB,CCCC"
[B][COLOR=#008000]'**************************************************************[/COLOR][/B]

[B][COLOR=#008000]'***********************************************[/COLOR][/B]
Private Const SHEET_NAME = "Sheet1"
Private Const SHEET_PROTECTION_PASSWORD = "1234"
[B][COLOR=#008000]'***********************************************[/COLOR][/B]

[B][COLOR=#008000]'********************************************[/COLOR][/B]
Private Const DROPDOWN_1_NAME = "MyDropDown1"
Private Const DATE_STAMP_CELL_1 = "Q7"
[COLOR=#008000]'********************************************[/COLOR]

[B][COLOR=#008000]'********************************************[/COLOR][/B]
Private Const DROPDOWN_2_NAME = "MyDropDown2"
Private Const DATE_STAMP_CELL_2 = "Q8:Q9"
[B][COLOR=#008000]'********************************************[/COLOR][/B]


Private Sub Workbook_Open()
    Call Populate_DropDowns
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Sheets(SHEET_NAME).Shapes(DROPDOWN_1_NAME).OLEFormat.Object.List = vbNullString
    Sheets(SHEET_NAME).Shapes(DROPDOWN_2_NAME).OLEFormat.Object.List = vbNullString
End Sub

Private Sub Populate_DropDowns()
    Dim arUsers() As String, sTargetDropDown As String, i As Integer

    arUsers = Split("Please Select," & "    " & Replace(USER_NAMES_1, ",", ",    "), ",")

    For i = 1 To 2
        sTargetDropDown = IIf(i = 1, DROPDOWN_1_NAME, DROPDOWN_2_NAME)
        With Sheets(SHEET_NAME).Shapes(sTargetDropDown).OLEFormat.Object
            .LinkedCell = vbNullString
            .ListFillRange = vbNullString
            .List = arUsers
            .Value = 1
            .OnAction = Me.CodeName & ".DropDowns_Macro"
        End With
    Next i
End Sub


Private Sub DropDowns_Macro()
    Dim arUsers() As String, arPassWords() As String
    Dim sAnsw As String, bCorrectPassword As Boolean
    
    arUsers = Split("Please Select," & USER_NAMES_1, ",")
    arPassWords = Split(USER_NAMES_1_PASSWORDS, ",")
    
    With ActiveSheet.Shapes(Application.Caller).OLEFormat.Object
        sAnsw = InputBox(LTrim(arUsers(.Value - 1)) & " ," & vbNewLine & vbNewLine & "Plesae , Enter Your Password.", "Date Stamp")
        Select Case True
            Case StrPtr(sAnsw) = 0
                bCorrectPassword = True
            Case Not (IsError(Application.Match(CVar(sAnsw), arPassWords(), 0)))
                If Application.Match(CVar(arUsers(.Value - 1)), arUsers(), 0) - 1 = Application.Match(CVar(sAnsw), arPassWords(), 0) Then
                    bCorrectPassword = True
                    Application.EnableEvents = False
                    .Parent.Unprotect SHEET_PROTECTION_PASSWORD
                    .Parent.Range(IIf(Application.Caller = DROPDOWN_1_NAME, DATE_STAMP_CELL_1, DATE_STAMP_CELL_2)) = _
                    Left(LTrim(arUsers(.Value - 1)), 1) & Mid(LTrim(arUsers(.Value - 1)), InStr(1, LTrim(arUsers(.Value - 1)), Chr(32)) + 1, 1) & "  " & Date
                    .Parent.Range(DATE_STAMP_CELL_1, DATE_STAMP_CELL_2).Locked = True
                    .Parent.Range(IIf(Application.Caller = DROPDOWN_1_NAME, DATE_STAMP_CELL_1, DATE_STAMP_CELL_2)).EntireColumn.AutoFit
                    .Parent.Protect SHEET_PROTECTION_PASSWORD
                    Application.EnableEvents = True
                End If
        End Select
        .Value = 1
        If bCorrectPassword = False Then MsgBox "Wrong Password !" & vbNewLine & vbNewLine & "Try Again.", vbCritical
    End With
End Sub

For Comboboxes populated each with different group of people, see next post

 

[Jaafar Tribak]

This is a slightly more involved code that works where each combobox is now optionally populated with different groups of people.

Workbook Sample

the above workbook sample has added in it two toggle checkboxes for convinience : One checkbox toggles the names in the comboboxes between 1-the same group of people in the two comboboxes and 2- different group of people each group in one combobox.

Again, the Username, passwords etc are all declared as constants at the top of the module for easy use and editing.

Code in the ThisWorkbook Module:

Option Explicit

[B][COLOR=#008000]'****************************************************************[/COLOR][/B]
[COLOR=#008000]'MyDropDown1 UserNames and their respective passwords ... Change as needed.[/COLOR]
Private Const USER_NAMES_1 = "Sarah Bing,John Doe,Mary Jane"
Private Const USER_NAMES_1_PASSWORDS = "AAAA,BBBB,CCCC"
[B][COLOR=#008000]'****************************************************************[/COLOR][/B]

[B][COLOR=#008000]'***********************************************************************************************************[/COLOR][/B]
[COLOR=#008000]'MyDropDown2 UserNames and their respective passwords ... Change as needed.[/COLOR]
Private Const USER_NAMES_2 = "Claire Gibbard,Peter Brown,Omar Gonsalez,Lisa Gerard,Charles Douglas"
Private Const USER_NAMES_2_PASSWORDS = "VVVV,WWWW,XXXX,YYYY,ZZZZ"
[B][COLOR=#008000]'***********************************************************************************************************[/COLOR][/B]

[B][COLOR=#008000]'***********************************************[/COLOR][/B]
Private Const SHEET_NAME = "Sheet1"
Private Const SHEET_PROTECTION_PASSWORD = "1234"
[B][COLOR=#008000]'***********************************************[/COLOR][/B]

[B][COLOR=#008000]'********************************************[/COLOR][/B]
Private Const DROPDOWN_1_NAME = "MyDropDown1"
Private Const DATE_STAMP_CELL_1 = "Q7"
[B][COLOR=#008000]'********************************************[/COLOR][/B]

[COLOR=#008000]'********************************************[/COLOR]
Private Const DROPDOWN_2_NAME = "MyDropDown2"
Private Const DATE_STAMP_CELL_2 = "Q8:Q9"
[COLOR=#008000]'********************************************[/COLOR]

[B][COLOR=#008000]'********************************************[/COLOR][/B]
Private Const DUPLICATE_USERNAMES_CHECKBOX = "MyCheckBox1"
Private Const SHEET_PROTECTION_CHECKBOX = "MyCheckBox2"
[B][COLOR=#008000]'********************************************[/COLOR][/B]

Private bDuplicateUserNames As Boolean

Private Sub Workbook_Open()
    Call SetUp_CheckBoxes
    Call Populate_DropDowns
End Sub


Private Sub SetUp_CheckBoxes()
    With Sheets(SHEET_NAME).Shapes(DUPLICATE_USERNAMES_CHECKBOX)
        .ControlFormat.Value = xlOff
        .OLEFormat.Object.OnAction = Me.CodeName & ".MyCheckBox1_Macro"
        bDuplicateUserNames = CBool(.OLEFormat.Object.Value - xlOff)
    End With
    
    With Sheets(SHEET_NAME).Shapes(SHEET_PROTECTION_CHECKBOX)
        .Parent.Protect SHEET_PROTECTION_PASSWORD
        .ControlFormat.Value = xlOn
        .OLEFormat.Object.OnAction = Me.CodeName & ".MyCheckBox2_Macro"
    End With
End Sub


Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Sheets(SHEET_NAME).Shapes(DROPDOWN_1_NAME).OLEFormat.Object.List = vbNullString
    Sheets(SHEET_NAME).Shapes(DROPDOWN_2_NAME).OLEFormat.Object.List = vbNullString
End Sub


Private Sub MyCheckBox1_Macro()
    bDuplicateUserNames = CBool(Sheets(SHEET_NAME).Shapes(DUPLICATE_USERNAMES_CHECKBOX).ControlFormat.Value - xlOff)
    Call Populate_DropDowns
End Sub


Private Sub MyCheckBox2_Macro()
    With Sheets(SHEET_NAME)
        If CBool(.Shapes(SHEET_PROTECTION_CHECKBOX).ControlFormat.Value - xlOff) Then
            .Protect SHEET_PROTECTION_PASSWORD
        Else
            .Unprotect SHEET_PROTECTION_PASSWORD
        End If
    End With
End Sub


Private Sub Populate_DropDowns()
    Dim arUsers() As String, sTargetDropDown As String, i As Integer

    arUsers = Split("Please Select," & "    " & Replace(USER_NAMES_1, ",", ",    "), ",")

    For i = 1 To 2
        If bDuplicateUserNames = False And i = 2 Then
            arUsers = Split("Please Select," & "    " & Replace(USER_NAMES_2, ",", ",    "), ",")
        End If
    
        sTargetDropDown = IIf(i = 1, DROPDOWN_1_NAME, DROPDOWN_2_NAME)
        With Sheets(SHEET_NAME).Shapes(sTargetDropDown).OLEFormat.Object
            .LinkedCell = vbNullString
            .ListFillRange = vbNullString
            .List = arUsers
            .Value = 1
            .OnAction = Me.CodeName & ".DropDowns_Macro"
        End With
    Next i
End Sub


Private Sub DropDowns_Macro()
    Dim arUsers() As String, arPassWords() As String
    Dim sAnsw As String, bCorrectPassword As Boolean
    
    arUsers = Split("Please Select," & USER_NAMES_1, ",")
    arPassWords = Split(USER_NAMES_1_PASSWORDS, ",")

    If Application.Caller = DROPDOWN_2_NAME And bDuplicateUserNames = False Then
        arUsers = Split("Please Select," & USER_NAMES_2, ",")
        arPassWords = Split(USER_NAMES_2_PASSWORDS, ",")
    End If
    
    With ActiveSheet.Shapes(Application.Caller).OLEFormat.Object
        sAnsw = InputBox(LTrim(arUsers(.Value - 1)) & " ," & vbNewLine & vbNewLine & "Plesae , Enter Your Password.", "Date Stamp")
        Select Case True
            Case StrPtr(sAnsw) = 0
                bCorrectPassword = True
            Case Not (IsError(Application.Match(CVar(sAnsw), arPassWords(), 0)))
                If Application.Match(CVar(arUsers(.Value - 1)), arUsers(), 0) - 1 = Application.Match(CVar(sAnsw), arPassWords(), 0) Then
                    bCorrectPassword = True
                    Application.EnableEvents = False
                    .Parent.Unprotect SHEET_PROTECTION_PASSWORD
                    .Parent.Range(IIf(Application.Caller = DROPDOWN_1_NAME, DATE_STAMP_CELL_1, DATE_STAMP_CELL_2)) = _
                    Left(LTrim(arUsers(.Value - 1)), 1) & Mid(LTrim(arUsers(.Value - 1)), InStr(1, LTrim(arUsers(.Value - 1)), Chr(32)) + 1, 1) & "  " & Date
                    .Parent.Range(DATE_STAMP_CELL_1, DATE_STAMP_CELL_2).Locked = True
                    .Parent.Range(IIf(Application.Caller = DROPDOWN_1_NAME, DATE_STAMP_CELL_1, DATE_STAMP_CELL_2)).EntireColumn.AutoFit
                    .Parent.Protect SHEET_PROTECTION_PASSWORD
                    Application.EnableEvents = True
                End If
        End Select
        .Value = 1
        If bCorrectPassword = False Then MsgBox "Wrong Password !" & vbNewLine & vbNewLine & "Try Again.", vbCritical
    End With
End Sub