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!

 

[tlc53]

Hi Mike,
The reason I tagged you is that you kindly helped me out with the original code. As you will see, I want to make a few changes.
Is it possible or am I asking too much?
Thank you!

 

[Jaafar Tribak]

What is the input cell that will hold the date ? Is it the same input cell for all users or a different cell for each user ?

Also what kind of combobox are you using ? An ActiveX combo or a Forms combo ?

 

[tlc53]

Hi.
There are two of these combo boxes/password requirements. The first date input cell is located to the right of the Combo Box in cell Q7. The second is located to the right in merged cells Q8:Q9. For ease lets ignore code for Q8:Q9 because if we get Q7 right, I can duplicate the code later.
Yes, the input cell is the same for all users. There's a Form Combo Box (drop down menu) which they select their name from, it then prompts for a password, once entered correctly the date is put in Q7.

 

[Jaafar Tribak]

@tlc53

Workbook Demo.

Add a new combobox from the forms toolbar to Sheet1 to the left of the date stamp cell Q7 and give the combo the name of MyDropDown

Do not set the ListFillRange or Linkedcell of the new combobox as the vba code will take care of that .Now place the following code in the ThisWorkbook Module :

Option Explicit

[B][COLOR=#008000]'change the dropdown name, sheet name and time stamp cell address as required.[/COLOR][/B]
Private Const DROPDOWN_NAME = "MyDropDown"
Private Const SHEET_NAME = "Sheet1"
Private Const DATE_STAMP_CELL = "Q7"

[B][COLOR=#008000]'change passwords as required.[/COLOR][/B]
Private Const SARAH_BING_PASSWORD = "AAAA"
Private Const JOHN_DOE_PASSWORD = "BBBB"
Private Const MARY_JANE_PASSWORD = "CCCC"

Private Sub Workbook_Activate()
    Call Populate_DropDown
End Sub

Private Sub Populate_DropDown()
    Dim arUsers() As Variant
    
    arUsers = Array("Please Select", "Sarah Bing", "John Doe", "Mary Jane")
    With Sheets(SHEET_NAME).Shapes(DROPDOWN_NAME).OLEFormat.Object
        .LinkedCell = vbNullString
        .ListFillRange = vbNullString
        .List = arUsers
        .Value = 1
        .OnAction = Me.CodeName & ".DropDown_Macro"
    End With
End Sub


Private Sub DropDown_Macro()
    Dim arUsers() As Variant, arPassWords() As Variant
    Dim sAnsw As String, bCorrectPassword As Boolean

    arUsers = Array("Please Select", "Sarah Bing", "John Doe", "Mary Jane")
    arPassWords = Array(SARAH_BING_PASSWORD, JOHN_DOE_PASSWORD, MARY_JANE_PASSWORD)
    
    With ActiveSheet.Shapes(Application.Caller).OLEFormat.Object
        sAnsw = InputBox(arUsers(.Value - 1) & " ," & vbNewLine & vbNewLine & "Plesae Enter Your Password.", "Date Stamp")
        Select Case True
            Case StrPtr(sAnsw) = 0
                .Value = 1
                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.Parent.Parent.Range(DATE_STAMP_CELL) = Left(arUsers(.Value - 1), 1) & _
                    Mid(arUsers(.Value - 1), InStr(1, arUsers(.Value - 1), Chr(32)) + 1, 1) & "  " & Date
                    Application.EnableEvents = True
                    .Parent.Parent.Parent.Range(DATE_STAMP_CELL).EntireColumn.AutoFit
                End If
            Case StrPtr(sAnsw) <> 0
                bCorrectPassword = False
        End Select
        .Value = 1
        If bCorrectPassword = False Then MsgBox "Wrong Password !" & vbNewLine & vbNewLine & "Try Again.", vbCritical
    End With
End Sub

I have declared the user's respective passwords as Constants at the top of the module for easy use and editing.

The code should take effect after re-opening the workbook.

 

[tlc53]

*A*M*A*Z*I*N*G*
That is the most impressive code I have come across.
Thank you so much for taking the time to write it. Your instructions were easy to follow and it works perfectly! I keep trying it out just for the fun of it

Thanks again!! You've made my day!

 

[Jaafar Tribak]

@tlc53

I am glad you liked the code - Thank you.

I would recommend that you also password-protect the worsheet and have the Cell Q7 locked ... That way, the users won't be able to edit the date stamp cell manually ... Obviously, if you lock the cell , the code will have to be slightly tweaked .

 

[tlc53]

Yes, I was intending on locking the cells and password protecting the worksheet. I was going to do this near the end. I didn't realise it would affect the code. I've just tried it and it's returning error code 400. How do I get around this?
I'm currently trying to duplicate this code for the second drop down box which sits directly under this one (returns date stamp in merged cell Q8:Q9). I can see why the code can't just be copied and pasted again within the same sheet but I'm not quite sure how to go about fixing it. I'm just double checking, but I believe they will be the same group of people on each drop-down list. Is there an easy way around this also?

 

[tlc53]

I think our time zones are very different, so please no rush to answer.
I look forward to your reply when you're able to.
Thank you!

 

[Jaafar Tribak]

I think our time zones are very different, so please no rush to answer.
I look forward to your reply when you're able to.
Thank you!

Auckland is literally on the other side of the planet ! but I am a night owl so my bedtime is usually not very different from that of your country

I'll give your last request about the merged cells a try when I am ready and will post back if anything comes up.