Kellie220
New Member
- Joined
- Jan 23, 2024
- Messages
- 31
- Office Version
- 365
- Platform
- Windows
** 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
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