VBA/Excel/Access/Word/Excel/Cell Comments

Clean the comment

 
Private Function CleanComment(author As String, cmt As String) As String
    Dim tmp As String
    tmp = Application.WorksheetFunction.Substitute(cmt, author & ":", "")
    tmp = Application.WorksheetFunction.Substitute(tmp, Chr(10), "")
    CleanComment = tmp
End Function

Converts docstring column into comments on name column.

 
Private Sub Workbook_AfterXmlImport(ByVal Map As XmlMap, ByVal IsRefresh As Boolean, ByVal Result As XlXmlImportResult)
    If Map.Name <> "application_Map" Then Exit Sub
    Dim cel As Range, ws As Worksheet, rng As Range
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set rng = ws.ListObjects(1).ListColumns("name").Range
    For Each cel In rng
        If Not (cel.rument Is Nothing) Then cel.rument.Delete
        cel.AddComment cel.Offset(0, 1).Text
        rowID = cel.Row - rng.Row
    Next
End Sub

Count Comments

 
Sub CountComments()
    CommentCount = 0
    For Each cell In ActiveSheet.UsedRange
        On Error Resume Next
        x = cell.rument.Text
        If Err = 0 Then CommentCount = CommentCount + 1
    Next cell
    Debug.Print CommentCount
End Sub

Get the comment text

 
     Function GetCommentText(rCommentCell As Range)
     Dim strGotIt As String
         On Error Resume Next
         strGotIt = WorksheetFunction.Clean _
             (rCommentCell.rument.Text)
         GetCommentText = strGotIt
         On Error GoTo 0
     End Function
=GetCommentText(A1)

resize Comments

 
Sub CommentFitter1()
    Application.ScreenUpdating = False
    Dim x As range, y As Long
    
    For Each x In cells.SpecialCells(xlCellTypeComments)
        Select Case True
            Case Len(x.NoteText) <> 0
                With x.rument
                    .Shape.TextFrame.AutoSize = True
                    If .Shape.Width > 250 Then
                        y = .Shape.Width * .Shape.Height
                        .Shape.Width = 150
                        .Shape.Height = (y / 200) * 1.3
                    End If
                End With
        End Select
    Next x
    Application.ScreenUpdating = True
End Sub

Toggle Comments

 
Sub ToggleComments()
    If Application.DisplayCommentIndicator = xlCommentAndIndicator Then
        Application.DisplayCommentIndicator = xlCommentIndicatorOnly
    Else
        Application.DisplayCommentIndicator = xlCommentAndIndicator
    End If
End Sub

Tracking cell changes in a comment

 
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    For Each cell In Target
        With cell
            On Error Resume Next
            OldText = .rument.Text
            If Err <> 0 Then .AddComment
            MsgBox OldText & "Changed by " & Application.UserName & " at " & Now & vbLf
            .rument.Text NewText
            .rument.Visible = True
            .rument.Shape.Select
             Selection.AutoSize = True
            .rument.Visible = False
        End With
    Next cell
End Sub