Automatically add comment with cell edit history having no character limit

user_16109963 0
Viewed 62

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.

vba excel
1 Answers

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
user_4788840
Related