Date & Username Stamp Help

[Rob1984]

Hi,

I a pretty new to VBA and would like some support.

What I looking for is a piece of VBA code that will date stamp Column O Username Stamp Column P, based on the status in column K being changed to either - Resolved & Ignore/Resolved.

Ideally id like the O & P cells to be locked down an unchangeable - but this is only secondary - its a shared work book so not sure if locking the cells don would impact stability.

 

[Yongle]

Rather than protecting cells VBA below prevents user from selecting any cells in columns O & P
The code is case sensitive
- assumes both "Resolved" and "Ignore/Resolved" are selected from dropdown in column K

There are 2 options for user name - use whichever one is better for you
Excel UserName = Application.UserName
Windows UserName = Environ$("Username")

Put code in the SHEET module (it will not work if placed anywhere else)
right-click on sheet tab \ click View Code \ paste code into the code window \ return to Excel with {ALT}{F11}

[COLOR=#006400][I]'[B]date stamp[/B] Column O [B]Username Stamp[/B] Column P, based on the status in column K being changed to either - [B]Resolved[/B] & [B]Ignore/Resolved[/B][/I][/COLOR]

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Usr As String, Cell As Range
        With Application
            Usr = .UserName         [COLOR=#006400][I]'Windows user Name:    Usr = Environ$("Username")[/I][/COLOR]
            
            If Not Intersect(Range("K2:K" & Rows.Count), Target) Is Nothing Then
                    .EnableEvents = False
                For Each Cell In Target
                    If Cell = "Resolved" Or Cell = "Ignore/Resolved" Then Cell.Offset(, 4).Resize(, 2) = Array(Date, Usr)
                Next Cell
                    .EnableEvents = True
            End If
        End With
End Sub

[COLOR=#006400][I]'[B]O[/B] & [B]P [/B]cells to be locked down and unchangeable[/I][/COLOR]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
[COLOR=#006400][I]'prevent selecting any cells in columns O and P[/I][/COLOR]
    If Not Intersect(Range("O2:P" & Rows.Count), Target) Is Nothing Then Cells(Target.Row, "Q").Select
End Sub

 

[Rob1984]

Thank you, that work perfectly.

 

[Yongle]

thanks for your feedback