Initial and Date Stamp

[tlc53]

Hi there,

I currently have a drop down list which requires an individuals unique password to change it. Once a name is selected/the correct password is entered, I would like an initial and date stamp to be applied to the cell to the right of the drop down list. This stamp should only change again, if a new name is successfully selected from the drop down box (if the wrong password is entered, the drop down lists default is blank but date stamp shouldn't change).

Can someone please help me amend my code to include this initial and date stamp?

My Drop Down List is located in cell P8 and I'd like the Initial/Date stamp in S8.
Stamp eg. TR 12/02/2019

Thanks very much!

Option Explicit
Const Nick_Brown As String = "Nick1"
Const Tessa_Richards As String = "Tessa1"


Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim pwd As String
Dim Oops As Boolean


Application.EnableEvents = False


For Each cell In Target
If Not Intersect(cell, Range("P8")) Is Nothing And cell <> "" Then
pwd = Application.InputBox("Password for " & cell & ":", _
"Enter Password", Type:=2)
Select Case cell.Value
Case "Nick Brown"
If pwd <> Nick_Brown Then Oops = True
Case "Tessa Richards"
If pwd <> Tessa_Richards Then Oops = True
End Select

If Oops Then
MsgBox "Incorrect Password"
cell = ""
End If
End If
Next cell


Application.EnableEvents = True
End Sub

 

[DanteAmor]

try the following

Option Explicit
Const Nick_Brown As String = "Nick1"
Const Tessa_Richards As String = "Tessa1"


Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range
    Dim pwd As String
    Dim Oops As Boolean
    
    Oops = True
    For Each cell In Target
        If Not Intersect(cell, Range("P8")) Is Nothing And cell <> "" Then
            pwd = Application.InputBox("Password for " & cell & ":", _
                "Enter Password", Type:=2)
            Select Case cell.Value
                Case "Nick Brown"
                    If pwd = Nick_Brown Then Oops = False
                Case "Tessa Richards"
                    If pwd = Tessa_Richards Then Oops = False
            End Select
            
            If Oops Then
                MsgBox "Incorrect Password"
                Application.EnableEvents = False
                cell = ""
                Application.EnableEvents = True
            Else
                If Range("S8").Value = "" Then
                    Range("S8").Value = "TR " & Date
                End If
            End If
        End If
    Next cell
    
End Sub

 

[tlc53]

Hi. Thank you!
That puts the date in nicely but I need the initials to be unique to the user. So Tessa Richards would be TR, Nick Brown would be NB then the date, etc.
I have a formula which does this but I am not sure how to write it into the VBA code;
=LEFT(P8)&IF(ISNUMBER(FIND(" ",P8)),MID(P8,FIND(" ",P8)+1,1),"")&IF(ISNUMBER(FIND(" ",P8,FIND(" ",P8)+1)),MID(P8,FIND(" ",P8,FIND(" ",P8)+1)+1,1),"")

 

[DanteAmor]

Try:

Option Explicit
Const Nick_Brown As String = "Nick1"
Const Tessa_Richards As String = "Tessa1"


Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range
    Dim pwd As String
    Dim Oops As Boolean
    
    Oops = True
    For Each cell In Target
        If Not Intersect(cell, Range("P8")) Is Nothing And cell <> "" Then
            pwd = Application.InputBox("Password for " & cell & ":", _
                "Enter Password", Type:=2)
            Select Case cell.Value
                Case "Nick Brown"
                    If pwd = Nick_Brown Then
                        Oops = False
                        If Range("S8").Value = "" Then
                            Range("S8").Value = "NB " & Date
                        End If
                    End If
                Case "Tessa Richards"
                    If pwd = Tessa_Richards Then
                        Oops = False
                        If Range("S8").Value = "" Then
                            Range("S8").Value = "NB " & Date
                        End If
                    End If
            End Select
            
            If Oops Then
                MsgBox "Incorrect Password"
                Application.EnableEvents = False
                cell = ""
                Application.EnableEvents = True
            End If
        End If
    Next cell
    
End Sub

 

[tlc53]

Thanks but there will be many names added, so I need it to look at the letter of the persons first name and the first letter of their last name, and return the initials followed by the date. I need it to be automatic, rather than writing the actual initials into the code.
Not to worry, the date part was very helpful. Thank you!

 

[DanteAmor]

Soory, change in the second "NB" by "TR"

Case "Nick Brown"
                    If pwd = Nick_Brown Then
                        Oops = False
                        If Range("S8").Value = "" Then
                            Range("S8").Value = "NB " & Date
                        End If
                    End If
                Case "Tessa Richards"
                    If pwd = Tessa_Richards Then
                        Oops = False
                        If Range("S8").Value = "" Then
                            Range("S8").Value = "[COLOR=#0000ff]TR[/COLOR]" & Date
                        End If
                    End If

 

[tlc53]

Thank you! This is working for me. I will just need to set each persons initials in the code.
The only problem I'm having, if I select Nick Brown, NB 14/02/2019 is put in cell S8 (which is correct) but if I then select Tessa Richards, it will not overwrite the contents of S8. It remains with the original entry of NB 14/02/2019. Any ideas please?

 

[DanteAmor]

Check this:

Option Explicit
Const Nick_Brown As String = "Nick1"
Const Tessa_Richards As String = "Tessa1"


Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range
    Dim pwd As String
    Dim Oops As Boolean
    
    Oops = True
    For Each cell In Target
        If Not Intersect(cell, Range("P8")) Is Nothing And cell <> "" Then
            pwd = Application.InputBox("Password for " & cell & ":", _
                "Enter Password", Type:=2)
            Select Case cell.Value
                Case "Nick Brown"
                    If pwd = Nick_Brown Then
                        Oops = False
                        If Range("S8").Value = "" Then
                            Range("S8").Value = "NB " & Date
                        Else
                            If Left(Range("S8").Value, 2) <> "NB" Then
                                Range("S8").Value = "NB " & Date
                            End If
                        End If
                    End If
                Case "Tessa Richards"
                    If pwd = Tessa_Richards Then
                        Oops = False
                        If Range("S8").Value = "" Then
                            Range("S8").Value = "TR " & Date
                        Else
                            If Left(Range("S8").Value, 2) <> "TR" Then
                                Range("S8").Value = "TR " & Date
                            End If
                        End If
                    End If
            End Select
            
            If Oops Then
                MsgBox "Incorrect Password"
                Application.EnableEvents = False
                cell = ""
                Application.EnableEvents = True
            End If
        End If
    Next cell
    
End Sub

 

[tlc53]

Lovely! Thank you

 

[tlc53]

Hi again. Sorry, one last thing! Now I'm trying to add a secondary sign-off approval directly above. In this area there are 3x individuals (Tessa, Christina & Colleen).
It's not liking my code at all. First error is Ambiguous name detected. I'm not sure if I can group all the passwords together at the top or if I have to duplicate them for each group (Principal & Reviewer). Any ideas how to make this work please?

'Principal Details
Option Explicit
Const Nick_Brown As String = "Nick1"
Const Tessa_Richards As String = "Tessa1"


Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim pwd As String
Dim Oops As Boolean

Oops = True
For Each cell In Target
If Not Intersect(cell, Range("P8")) Is Nothing And cell <> "" Then
pwd = Application.InputBox("Password for " & cell & ":", _
"Enter Password", Type:=2)

Select Case cell.Value
Case "Nick Brown"
If pwd = Nick_Brown Then
Oops = False
If Range("S8").Value = "" Then
Range("S8").Value = "NB " & Date
Else
If Left(Range("S8").Value, 2) <> "NB" Then
Range("S8").Value = "NB " & Date
End If
End If
End If

Case "Tessa Richards"
If pwd = Tessa_Richards Then
Oops = False
If Range("S8").Value = "" Then
Range("S8").Value = "TR " & Date
Else
If Left(Range("S8").Value, 2) <> "TR" Then
Range("S8").Value = "TR " & Date
End If
End If
End If

End Select

If Oops Then
MsgBox "Incorrect Password"
Application.EnableEvents = False
cell = ""
Application.EnableEvents = True
End If
End If
Next cell

End Sub


'Reviewer Details
Option Explicit
Const Tessa_Richards As String = "Tessa1"
Const Christina_Hoover As String = "Chris1"
Const Colleen_Marshall As String = "Colleen1"


Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim pwd As String
Dim Oops As Boolean

Oops = True
For Each cell In Target
If Not Intersect(cell, Range("P7")) Is Nothing And cell <> "" Then
pwd = Application.InputBox("Password for " & cell & ":", _
"Enter Password", Type:=2)

Select Case cell.Value

Case "Tessa Richards"
If pwd = Tessa_Richards Then
Oops = False
If Range("S7").Value = "" Then
Range("S7").Value = "TR " & Date
Else
If Left(Range("S8").Value, 2) <> "TR" Then
Range("S7").Value = "TR " & Date
End If
End If
End If

Case "Christina Hoover"
If pwd = Christina_Hoover Then
Oops = False
If Range("S7").Value = "" Then
Range("S7").Value = "CH " & Date
Else
If Left(Range("S7").Value, 2) <> "NB" Then
Range("S7").Value = "CH " & Date
End If
End If
End If

Case "Colleen Marshall"
If pwd = Colleen_Marshall Then
Oops = False
If Range("S7").Value = "" Then
Range("S7").Value = "CM " & Date
Else
If Left(Range("S7").Value, 2) <> "NB" Then
Range("S7").Value = "CM " & Date
End If
End If
End If

End Select

If Oops Then
MsgBox "Incorrect Password"
Application.EnableEvents = False
cell = ""
Application.EnableEvents = True
End If
End If
Next cell

End Sub