Automatically add comment with cell edit history having no character limit - excel

Question

I am using the below code from this link
Need help
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
'If (Target.Row > 3 And Target.Row < 155) Then Cells(Target.Row, "AT") = Now()
Const sRng As String = "A5:AQ155" ' change as required
Dim sOld As String
Dim sNew As String
Dim sCmt As String
Dim iLen As Long
Dim bHasComment As Boolean
With Target(1)
If Intersect(.Cells, Me.Range(sRng)) Is Nothing Then
Application.EnableEvents = True
Exit Sub
End If
sNew = .Text
sOld = .Text
.Value = sNew
Application.EnableEvents = True
sCmt = "Edit: " & Format$(Now, "dd Mmm YYYY hh:nn:ss") & " by " & Application.UserName & Chr(10) & "Previous Text :- " & sOld
If Target(1).Comment Is Nothing Then
.AddComment
Else
iLen = Len(.Comment.Shape.TextFrame.Characters.Text)
End If
With .Comment.Shape.TextFrame
.AutoSize = True
.Characters(Start:=iLen + 1).Insert IIf(iLen, vbLf, "") & sCmt
End With
End With
End Sub
Sub Hide_Comments_in_Workbook_Completely()
'This macro hides the comments and comment indicators - users wont know there is a comment within the excel workbook
Application.DisplayCommentIndicator = xlNoIndicator
End Sub
The above code works fine only one problem I am facing.
It creates a history of 9 changes in 9 lines in comments if the changes exceeded or Total Character (with space) in comments is 268 more then the previous line is automatically erased.
Can anyone help me to overcome the above problem?
I want no bindings of changes or character input or line limits.
Thanks in advance and appreciate any help.

Answer 1

Characters is limited in the length of text you can address. You could instead delete and re-add the comment with the new text added.
This worked for me in testing:
Private Sub Worksheet_Change(ByVal Target As Range)
Const sRng As String = "A5:AQ155" ' change as required: must be a contiguous range
Dim c As Range, rng As Range, oldVals, newVals, newValsTgt, usr
Dim col As Long, rw As Long, txt As String, s As String
If Target.Areas.Count > 1 Then Exit Sub 'only handling single Area changes
Set rng = Application.Intersect(Target, Me.Range(sRng))
If rng Is Nothing Then Exit Sub
On Error GoTo haveError
Application.EnableEvents = False 'don't re-trigger event
newValsTgt = ToArray(Target) 'get current Target values
newVals = ToArray(rng) 'get current values for range of interest
Application.Undo 'restore previous values
oldVals = ToArray(rng) 'get pre-update values for range of interest
Target.Value = newValsTgt 'restore the Target range values
Application.EnableEvents = True
usr = Application.UserName
For rw = 1 To UBound(newVals, 1) 'loop over the new values
For col = 1 To UBound(newVals, 2)
If newVals(rw, col) <> oldVals(rw, col) Then 'was the content changed?
Set c = rng.Cells(rw, col)
s = "Edit: " & Format$(Now, "dd Mmm YYYY hh:nn:ss") & _
" by " & usr & Chr(10) & _
"Previous Text :- " & oldVals(rw, col)
If c.Comment Is Nothing Then
c.AddComment s
Else
txt = c.Comment.Text
c.Comment.Delete
c.AddComment s & vbLf & txt
End If
c.Comment.Shape.TextFrame.AutoSize = True
End If
Next col
Next rw
Exit Sub 'normal exit
haveError:
Debug.Print "Error: " & Err.Description
Application.EnableEvents = True 'ensure events are back on
End Sub
'returns the value of both single cells and ranges as an array...
Function ToArray(rng As Range)
Dim rv
If rng.CountLarge = 1 Then
ReDim rv(1 To 1, 1 To 1)
rv(1, 1) = rng.Value
ToArray = rv
Else
ToArray = rng.Value
End If
End Function