VBA Code Creates Comments with Username and date/timestamp - Need permanent entries

[Kellie220]

** The Below code I found here, user name Hask123, not my code.** Hask123 found a similar code online and manipulated it to their needs. This seems to be what I need as well, and I need to manipulate it to my needs. I do not have a range but a coulmn I need to use it in. This would be Column A cell 2 through cell 9999 (the whole column A excluding my header). I also need what is put into the cell once it is date/user stamped to not be over road when adding a new comment to the cell. Keep the string of successive comments but make them permanent within the cell. Any suggestion on that? This is for tracking comments on each row of data. We need to track the history of what happens to the data in each row over time (Comment section). We do not want to lose visibility of the previous comments, yet we need to add new comments. Any suggestions? Is this doable?

Code:

Private Sub Worksheet_Change(ByVal Target As Range)



Dim MyTargetRange As Range

Set MyTargetRange = ActiveSheet.Range("E17:E65")



If Not Intersect(Target, Range("E17:E65")) Is Nothing Then 'Change this range as appropriate.

If Target.Cells.Count = 1 Then

If Len(Target.Formula) > 0 Then



'If 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(), "ddd dd-mmm-yy hh:mm")



With .Shape.TextFrame

.Characters(1, .Characters.Count).Font.Bold = False 'make the whole comment non-bold

'.Characters(InStrRev(Target.Comment.Text, Environ("USERNAME")), Len(Environ("USERNAME"))).Font.Bold = True 'Make Bold the LAST occurrence of USERNAME

.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(), "ddd dd-mmm-yy hh:mm")

With .Shape.TextFrame

'.Characters(1, Len(Environ("USERNAME"))).Font.Bold = True

.AutoSize = True

End With

End With

End With



End If



'Embolden each occurrence of Environ("USERNAME") in each comment in E17:E55

For Each cCom In ActiveSheet.Range("E17:E65").SpecialCells(xlCellTypeComments)

With Cells(cCom.Row, cCom.Column).Comment.Shape.TextFrame

For i = 1 To Len(cCom.Comment.Text) Step 1[/CODE]
[/CODE]

If Mid(cCom.Comment.Text, i, Len(Environ("USERNAME"))) = Environ("USERNAME") Then

.Characters(i, Len(Environ("USERNAME"))).Font.Bold = True

End If

Next i

End With

Next cCom

 

[skillilea]

Side Note. We want to put this in the Cloud on a SharePoint. I know Marcos do not work in the Cloud? Maybe I am wrong in this?

You can run your sheet on OneDrive even if the file is in sharepoint. Is that an option?

If you want me to look at the sheet for you. You can send a sample to sean.killilea.fd@gmail.com.

 

[Kellie220]

1) I get a sense of the importance that you attach to this data. If it's that important, that critical, would you be better off moving to a database where you could have related comments that weren't limited in either length or number?
3) With $A:$F being an edit range, once the password for that range has been entered, it is active for that session, and that range can be edited. However, that password must be entered before that can happen. You're better off turning off the Locked attribute for that range, then protecting the worksheet. Then anyone who can open the workbook can edit those cells. (If you want to limit who can edit the workbook, then add a password to the workbook.)

Note: If you handle the changes to the A column solely in your VBA code, then column A doesn't need to be included in either the edit range or the unlocked cells, whichever option you choose. If you display an InputBox asking for a comment, then unprotect the worksheet, add the new comment, then protect the worksheet again, you've achieved the protection and functionality that you want.

My understanding is that macros don't work in Excel on the web, however it shouldn't make any difference where the file is stored - cloud or not - if you are using it in 365. If you want macro-type functionality, but in Excel on the web, then you will need to code in another language.

Yes, I use Boolean because protection is either on or off. So you would use it in the code like so:

If UnProtectSheet(ActiveSheet) Then
    ' Do something'
    If ProtectSheet(ActiveSheet) Then
        ' Do another thing
    End If
End If

Note: the functions ProtectActive() and UnProtectActive() listed in my previous post should not be marked Private; both should have the word Private deleted.

In thinking about your requirements, if it's true that:
A) Column A is reserved for comments.
B) Users should, but don't have to, add a comment for any change they make.
then the following code in your worksheet code module should give the result that you want.

Private Sub Worksheet_Change(ByVal Target As Range)
    Const cstrTitle As String = "Add Comment"
    Const clngColA As Long = 1   ' Column for comments
    Dim strAudit As String
    Dim rngToAudit As Range
    Dim rngTgtCell As Range
    Dim rngTgtArea As Range
    Dim rngComment As Range
    Dim rngCell As Range
    Dim strUser As String
    Dim lngPosn As Long
    Dim strComment As String
    Dim strErrMsg As String
    Dim bolUnprotected As Boolean
    '
    'Change this range as appropriate.
    Set rngToAudit = ActiveSheet.Range("E17:E65")
    strErrMsg = vbNullString
    bolUnprotected = False
    '
    ' Are any of the changed cells within the audit range?
    If (Not (Intersect(Target, rngToAudit) Is Nothing)) Then
        ' They are, so comment them.
        If UnProtectActive() Then
            bolUnprotected = True
            strUser = Environ("USERNAME")
            strAudit = strUser & Space(1) & Format(Now(), "ddd dd mmm yy hh:mm")
            ' Process each Area.
            For Each rngTgtArea In Target.Areas
                ' Process each Cell within the Area.
                For Each rngTgtCell In rngTgtArea.Cells
                    ' Is this particular cell in the audit range?
                    If (Not (Intersect(rngTgtCell, rngToAudit) Is Nothing)) Then
                        ' It is.
                        rngTgtCell.Select
                        strComment = Application.InputBox("Comment for Row " & rngTgtCell.Row, cstrTitle, vbNullString)
                        If (Not (strComment = "False")) Then
                            strComment = strAudit & vbLf & strComment
                            Set rngComment = Me.Cells(rngTgtCell.Row, clngColA)
                            If (rngComment.Comment Is Nothing) Then
                                'There is no comment yet, so create one and add audit string.
                                With rngComment
                                    .AddComment
                                    With .Comment
                                        .Shape.AutoShapeType = msoShapeRoundedRectangle
                                        .Text Text:=strComment
                                    End With
                                End With
                            Else
                                'Since a comment already exists, add a line feed after audit string.
                                With rngComment.Comment
                                    .Text Text:=strComment & vbLf & .Text
                                End With
                            End If
                        End If
                    End If
                Next rngTgtCell
            Next rngTgtArea
            ' Bold all occurrences of the current UserName in each comment in given range.
            For Each rngCell In Me.Columns(clngColA).SpecialCells(xlCellTypeComments)
                With rngCell.Comment
                    ' Turn off bold completely for this comment.
                    .Shape.TextFrame.Characters.Font.Bold = False
                    ' Bold all occurrences of the current UserName in this Comment.
                    lngPosn = InStr(1, .Text, strUser)
                    Do While (lngPosn > 0)
                        .Shape.TextFrame.Characters(lngPosn, Len(strUser)).Font.Bold = True
                        lngPosn = InStr(lngPosn + 1, .Text, strUser)
                    Loop
                    ' AutoSize the comment.
                    .Shape.TextFrame.AutoSize = True
                End With
            Next rngCell
        End If
    End If
Housekeeping:
    If bolUnprotected Then
        ProtectActive
    End If
    ' Display any error message.
    If (Trim(strErrMsg) <> vbNullString) Then
        MsgBox strErrMsg, vbCritical + vbOKOnly, cstrTitle
    End If
    Exit Sub
Err_Exit:
    strErrMsg = Err.Number & ": " & Err.Description
    Err.Clear
    Resume Housekeeping
End Sub

Then the protection procedures can be put into a regular module.

' Return the password used to protect the spreadsheets.
Private Function SheetPwd() As String
    SheetPwd = "P@^pW@7]D#!4"
End Function

' Password protect all spreadsheets.
Function ProtectAllSheets() As Boolean
    Dim wks As Worksheet
    Dim bolResult As Boolean
    '
    ProtectAllSheets = False
    On Error GoTo Err_Exit
    bolResult = True
    For Each wks In Worksheets
        bolResult = bolResult And ProtectSheet(wks)
    Next
    ProtectAllSheets = bolResult
Housekeeping:
    Exit Function
Err_Exit:
    Err.Clear
    Resume Housekeeping
End Function

' Unprotect all worksheets.
Function UnProtectAllSheets() As Boolean
    Dim wks As Worksheet
    Dim bolResult As Boolean
    '
    UnProtectAllSheets = False
    On Error GoTo Err_Exit
    bolResult = True
    For Each wks In ThisWorkbook.Worksheets
        bolResult = bolResult And UnProtectSheet(wks)
    Next
    UnProtectAllSheets = bolResult
Housekeeping:
    Exit Function
Err_Exit:
    Err.Clear
    Resume Housekeeping
End Function

' Password protect a given spreadsheet.
Function ProtectSheet(wks As Worksheet) As Boolean
    On Error GoTo Err_Exit
    ProtectSheet = False
    wks.Protect Password:=SheetPwd(), UserInterfaceOnly:=True
    ProtectSheet = WksIsProtected(wks)
Housekeeping:
    Exit Function
Err_Exit:
    Err.Clear
    Resume Housekeeping
End Function

' Unprotect a given spreadsheet.
Function UnProtectSheet(wks As Worksheet) As Boolean
    On Error GoTo Err_Exit
    UnProtectSheet = False
    wks.Unprotect Password:=SheetPwd()
    UnProtectSheet = (Not WksIsProtected(wks))
Housekeeping:
    Exit Function
Err_Exit:
    Err.Clear
    Resume Housekeeping
End Function

' Unprotect the active worksheet.
Function UnProtectActive() As Boolean
    UnProtectActive = UnProtectSheet(ActiveSheet)
End Function

' Protect the active worksheet.
Function ProtectActive() As Boolean
    ProtectActive = ProtectSheet(ActiveSheet)
End Function

' Determine if the given worksheet is protected.
Function WksIsProtected(wks As Worksheet) As Boolean
    'Debug.print "WksIsProtected"
    On Error GoTo Err_Exit
    WksIsProtected = (wks.ProtectContents Or wks.ProtectScenarios Or wks.ProtectDrawingObjects)
Housekeeping:
    Exit Function
Err_Exit:
    Err.Clear
    Resume Housekeeping
End Function

' Is a given worksheet protected with a password?
Function HasPassword(wks As Worksheet) As Boolean
    Dim bolScrnUpdating As Boolean
    bolScrnUpdating = Application.ScreenUpdating
    HasPassword = False
    Application.ScreenUpdating = False
    If wks.ProtectContents Then
        On Error Resume Next
        wks.Protect Password:="", Contents:=False
        If Err = 1004 Then
            HasPassword = True
        End If
        On Error GoTo 0
    End If
    If bolScrnUpdating Then
        Application.ScreenUpdating = True
    End If
End Function

' Protect the workbook.
Function ProtectWorkbook() As Boolean
    'Debug.print "ProtectWorkbook"
    ProtectWorkbook = False
    On Error GoTo Err_Exit
    ThisWorkbook.Protect Password:=SheetPwd(), Structure:=True
    ProtectWorkbook = True
Housekeeping:
    Exit Function
Err_Exit:
    Err.Clear
    Resume Housekeeping
End Function

' Unprotect the workbook.
Function UnprotectWorkbook() As Boolean
    'Debug.print "UnprotectWorkbook"
    UnprotectWorkbook = False
    On Error GoTo Err_Exit
    ThisWorkbook.Unprotect Password:=SheetPwd()
    UnprotectWorkbook = True
Housekeeping:
    Exit Function
Err_Exit:
    Err.Clear
    Resume Housekeeping
End Function

' Determine if the workbook is protected.
Function WorkbookIsProtected() As Boolean
    'Debug.print "WorkbookIsProtected"
    WorkbookIsProtected = (ThisWorkbook.ProtectStructure Or ThisWorkbook.ProtectWindows)
Housekeeping:
    Exit Function
Err_Exit:
    Err.Clear
    Resume Housekeeping
End Function

Once the respective pieces of code are in place:
1) Change the procedure SheetPwd to be whatever your password is, and
2) Run the procedure ProtectActive.
Then you should be set for testing.

Hi there, I apologize for the delay in response, 2 jobs sometimes don't work well LOL I will try the above. I appreciate the explanation along with the code. It does help make things clearer. I will message again after some initial testing. Thank you again for your time!!

 

[Kellie220]

You can run your sheet on OneDrive even if the file is in sharepoint. Is that an option?

If you want me to look at the sheet for you. You can send a sample to sean.killilea.fd@gmail.com.

Hi, thank you!! Sent!!

 

[Kellie220]

Hi there, I apologize for the delay in response, 2 jobs sometimes don't work well LOL I will try the above. I appreciate the explanation along with the code. It does help make things clearer. I will message again after some initial testing. Thank you again for your time!!

I am looking at the code and in your comment it has range E17:E65 is that from my original code I put in as an example? Am I to re-paste the new code you just gave? I am only looking for a code for Column A. Can you please tell me which to paste. Sorry, I think I am getting a bit confused with additional codes and not knowing if I am to add them or to erase old and add them as new? Thanks!

 

[skillilea]

If you sent something I never got it.

 

[CephasOz]

I am looking at the code and in your comment it has range E17:E65 is that from my original code I put in as an example? Am I to re-paste the new code you just gave? I am only looking for a code for Column A. Can you please tell me which to paste. Sorry, I think I am getting a bit confused with additional codes and not knowing if I am to add them or to erase old and add them as new? Thanks!

Hi @Kellie220

I know it can difficult changing some lines here and there, so I sent complete replacement procedures so you wouldn't have to worry about what was and wasn't changed. Just erase the previous version that I sent, and copy and paste the new ones. Easy! (But don't forget to change the password in the SheetPwd() function.)

Yes, the E17:E65 was from your post. I took what you wrote as being correct and coded that way. However, you can change that range to be anything you want other than cells in column A. If you have a user making a change in column A, that would lead to an endless cycle of a change causing a comment (which is a change), causing a comment (which is a change), causing a comment ...

Just to have everything clear, exactly which range(s) can the user update?

(At the moment, the code is written on the basis that the users are making changes elsewhere, but their comments are placed into the same row but in column A.)

 

[Kellie220]

Hi @Kellie220

I know it can difficult changing some lines here and there, so I sent complete replacement procedures so you wouldn't have to worry about what was and wasn't changed. Just erase the previous version that I sent, and copy and paste the new ones. Easy! (But don't forget to change the password in the SheetPwd() function.)

Yes, the E17:E65 was from your post. I took what you wrote as being correct and coded that way. However, you can change that range to be anything you want other than cells in column A. If you have a user making a change in column A, that would lead to an endless cycle of a change causing a comment (which is a change), causing a comment (which is a change), causing a comment ...

Just to have everything clear, exactly which range(s) can the user update?

(At the moment, the code is written on the basis that the users are making changes elsewhere, but their comments are placed into the same row but in column A.)

Hi. The "original" code I hade pasted was something I found in this thread that was very close to what I needed. I came here to ask help modifying it. Column A (the entire column) is what needs to have the pop out dialog comment box. Column A thru F are able to be modified by users but Columns G thru then last column are in a Range that is protected. The reason is that the information in Column G thru last Column is information pulled from an outside source and we then research that information and enter what we find in Columns A thru F with Column A being the "comments, or notes, or research results". The original post had a different range in which that person wanted pop out dialog boxes. Thanks for the clarity!!

 

[Kellie220]

If you sent something I never got it.

Hi I resent to sean.killilea.fd@gmail.com It will be coming from a Yahoo E-mail.

 

[skillilea]

That’s great. I’ll look for it. I have a different approach than my work for you.

 

[CephasOz]

If the only use for column A is for comments, then changing the range in the last procedure that I sent should do what you want.

    'Change this range as appropriate.
    Set rngToAudit = ActiveSheet.Columns("B:F")

The users change whatever they want in columns B to F, and then they have the opportunity to add a comment in column A.