Worksheet Change

[GomaPile]

Hello All,

Firstly the VBA below we didn't write this ourselves, it was found on Google forums. However it works perfectly for our department (Hospital) when rostering staff each fortnightly. It writes comments what you typed in that cell... your username | date & timestamps BUT what we would like to see happen also please.. If one of our Shift Coordinators accidentally deletes data, we would like the VBA to record who actually removed the info, and put back what was removed.

I'm not very good at writing VBA coding myself, is there someone out there who can help us to add a bit more VBA, if something was deleted by mistake....

Private Sub Worksheet_Change(ByVal Target As Range)
    
    On Error GoTo ErrHandler
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    '*** Disable this macro ***
    'Call unProtectSheet
           
        If Target.Cells.Count = 1 Then
            If Len(Target.Formula) > 0 Then
                
                'If a comment already exists, add a carriage return, username and timestamp to the current comment value.
                If Not Target.Comment Is Nothing Then
                    
                    With Target.Comment
                        MyString = Environ("USERNAME") & " " & Format(Now(), "ddd dd mmm yy hh:mm")
                        .Text Text:=Target.Comment.Text & Chr(10) & _
                            Environ("USERNAME") & " " & Format(Now(), "dd/mm/yy hh:mm:ss") & " " & Target.Value & Chr(10)
                            
                        'Calculate the position of the LAST occurrence of the UserName string
                        MyPosition = InStrRev(Target.Comment.Text, Environ("USERNAME"))
                            
                        With .Shape.TextFrame
                            .Characters(1, .Characters.Count).Font.Bold = False 'make the whole comment non-bold
                            .Characters(MyPosition, Len(Environ("USERNAME"))).Font.Bold = True
                            .AutoSize = True
                        End With
                    End With
                
                'If there is no comment yet, create one and add username and timestamp
                Else
                    
                    With Target
                        .AddComment
                        With .Comment
                            .Shape.AutoShapeType = msoShapeRoundedRectangle
                            .Text Text:=Environ("USERNAME") & " " & Format(Now(), "dd/mm/yy hh:mm:ss") & " " & Target.Value & Chr(10)
                            With .Shape.TextFrame
                                .Characters(1, Len(Environ("USERNAME"))).Font.Bold = True
                                .AutoSize = True
                            End With
                        End With
                    End With
                
                End If
            
            End If
        End If
    
    '*** Disable this macro ***
    'Call sbProtectSheetColour

ErrHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
    
End Sub

Gary

 

[Dermot]

Try replacing all your code with this

Dim prevvalue

Private Sub Worksheet_Change(ByVal target As Range)
    
    On Error GoTo ErrHandler
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    '*** Disable this macro ***
    'Call unProtectSheet
           
        If target.Cells.Count = 1 Then
            If Len(target.Formula) > 0 Then
              AddComment target
            ElseIf prevvalue <> "" Then
              AddComment target
              target.Value = prevvalue
              AddComment target, True
            End If
        End If
    
    '*** Disable this macro ***
    'Call sbProtectSheetColour

ErrHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
    
End Sub

Sub AddComment(target, Optional RestoringDeletion = "")
    Dim txt
    If RestoringDeletion <> "" Then txt = " - RESTORING DELETION"
    'If a comment already exists, add a carriage return, username and timestamp to the current comment value.
    If Not target.Comment Is Nothing Then
        
        With target.Comment
            MyString = Environ("USERNAME") & " " & Format(Now(), "ddd dd mmm yy hh:mm")
            .Text Text:=target.Comment.Text & Chr(10) & _
                Environ("USERNAME") & " " & Format(Now(), "dd/mm/yy hh:mm:ss") & " " & target.Value & txt & Chr(10)
                
            'Calculate the position of the LAST occurrence of the UserName string
            MyPosition = InStrRev(target.Comment.Text, Environ("USERNAME"))
                
            With .Shape.TextFrame
                .Characters(1, .Characters.Count).Font.Bold = False 'make the whole comment non-bold
                .Characters(MyPosition, Len(Environ("USERNAME"))).Font.Bold = True
                .AutoSize = True
            End With
        End With
    
    'If there is no comment yet, create one and add username and timestamp
    Else
        
        With target
            .AddComment
            With .Comment
                .Shape.AutoShapeType = msoShapeRoundedRectangle
                .Text Text:=Environ("USERNAME") & " " & Format(Now(), "dd/mm/yy hh:mm:ss") & " " & target.Value & txt & Chr(10)
                With .Shape.TextFrame
                    .Characters(1, Len(Environ("USERNAME"))).Font.Bold = True
                    .AutoSize = True
                End With
            End With
        End With
                
    End If

End Sub

Private Sub Worksheet_SelectionChange(ByVal target As Range)
  prevvalue = target.Cells(1, 1)
End Sub

 

[GomaPile]

Try replacing all your code with this

Dim prevvalue
Private Sub Worksheet_Change(ByVal target As Range)
   
    On Error GoTo ErrHandler
   
    Application.EnableEvents = False
    Application.ScreenUpdating = False
   
    '*** Disable this macro ***
    'Call unProtectSheet
          
        If target.Cells.Count = 1 Then
            If Len(target.Formula) > 0 Then
              AddComment target
            ElseIf prevvalue <> "" Then
              AddComment target
              target.Value = prevvalue
              AddComment target, True
            End If
        End If
   
    '*** Disable this macro ***
    'Call sbProtectSheetColour
ErrHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
   
End Sub
Sub AddComment(target, Optional RestoringDeletion = "")
    Dim txt
    If RestoringDeletion <> "" Then txt = " - RESTORING DELETION"
    'If a comment already exists, add a carriage return, username and timestamp to the current comment value.
    If Not target.Comment Is Nothing Then
       
        With target.Comment
            MyString = Environ("USERNAME") & " " & Format(Now(), "ddd dd mmm yy hh:mm")
            .Text Text:=target.Comment.Text & Chr(10) & _
                Environ("USERNAME") & " " & Format(Now(), "dd/mm/yy hh:mm:ss") & " " & target.Value & txt & Chr(10)
               
            'Calculate the position of the LAST occurrence of the UserName string
            MyPosition = InStrRev(target.Comment.Text, Environ("USERNAME"))
               
            With .Shape.TextFrame
                .Characters(1, .Characters.Count).Font.Bold = False 'make the whole comment non-bold
                .Characters(MyPosition, Len(Environ("USERNAME"))).Font.Bold = True
                .AutoSize = True
            End With
        End With
   
    'If there is no comment yet, create one and add username and timestamp
    Else
       
        With target
            .AddComment
            With .Comment
                .Shape.AutoShapeType = msoShapeRoundedRectangle
                .Text Text:=Environ("USERNAME") & " " & Format(Now(), "dd/mm/yy hh:mm:ss") & " " & target.Value & txt & Chr(10)
                With .Shape.TextFrame
                    .Characters(1, Len(Environ("USERNAME"))).Font.Bold = True
                    .AutoSize = True
                End With
            End With
        End With
               
    End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal target As Range)
  prevvalue = target.Cells(1, 1)
End Sub

 

[GomaPile]

Sorry Dermot, please disregard my last post above, didnt know we had expire limit when typing.



Hi Dermot, thank you for responding to my VBA code and thankyou for helping our department as well; we appreciate your support. Your VBA code does actually what you wrote - word for word. Sometimes its hard to tell a story in words without physically showing in person. And I may have said too much above... though we're on the right track.

I will show you what we SEE on the computer, though we just need one small change, if you have time please.

Displayed info inside cell comment section
Part A
What we're currently seeing:
- Gary 06/12/21 13:00:48 test
- Gary 06/12/21 13:01:02 test2
- Gary 06/12/21 13:01:11 test3
- Gary 06/12/21 13:01:16 <----- this section is not needed
- Gary 06/12/21 13:01:16 test3 - RESTORING DELETION

Part B (our prefer option)
What we're currently seeing:
- Gary 06/12/21 13:00:48 test
- Gary 06/12/21 13:01:02 test2
- Gary 06/12/21 13:01:11 test3
- Gary 06/12/21 13:01:16 test3 - DELETION <----- we like to see the info being deleted but NOT restored. Thats where I added too much info in my first post above and thats my fault, sorry my bad.


Gary