Excel Comment Programming

From http://www.contextures.com/xlcomments03.html

Change the User Name

Instead of showing the user name at the start of a comment, you can change to something generic, such as "Note:" However, this change affects the User Name in all Microsoft Office programs, so you may want to reset the name before you exit Excel.

To set a generic label:
Sub CommentNote()
    Application.UserName = "Note"
End Sub

To reset the User Name:    
Sub CommentName()
    Application.UserName = "John Smith"
End Sub
 
 

 
 

Insert a Plain Comment

To insert a comment with no User Name, use the following macro.
Note: Because the macro contains a SendKeys command, it should be run with the worksheet active, not Visual Basic Explorer.

Sub CommentAddOrEdit()
'adds new plain text comment or positions
'cursor at end of existing comment text
  Dim cmt As Comment
  Set cmt = ActiveCell.Comment
  If cmt Is Nothing Then
    ActiveCell.AddComment text:=""
  End If
  SendKeys "%ie~"
End Sub

To avoid use of the SendKeys command, you can use the following variation, which leaves the comments visible. After running the macro, the comment shape is selected. Start typing, and the text will be added to the comment box, or to the end of the existing comment text.

Sub CommentAddOrEdit()
'method suggested by Jon Peltier 2006-03-04
'adds new plain text comment or adds text
'at end of existing comment text
  Dim cmt As Comment
  Set cmt = ActiveCell.Comment
  If cmt Is Nothing Then
    Set cmt = ActiveCell.AddComment
    cmt.text text:=""
  End If
 
  'type to add comment text to selected shape
  cmt.Visible = True
  cmt.Shape.Select

End Sub
 

Replace Old Name in Comments

If a previous user inserted comments, their name may appear at the top of the comment. Their name may also appear in the Status Bar, when you hover over the cell that contains a comment. The following macro will replace the old name with a new name.

Sub ChangeCommentName()
'replaces old names in comments
'deletes and reinserts comments
'  so new name appears in status bar
Dim ws As Worksheet
Dim cmt As Comment
Dim strOld As String
Dim strNew As String
Dim strComment As String
strNew = "New Name"
strOld = "Old Name"
Application.UserName = strNew
For Each ws In ActiveWorkbook.Worksheets
  For Each cmt In ws.Comments
    strComment = Replace(cmt.text, strOld, strNew)
    cmt.Delete
    cmt.Parent.AddComment text:=strComment
  Next cmt
Next ws

End Sub
 
 

 
 

Insert a Formatted Comment

To insert a comment with no User Name, formatted in Times New Roman font, use the following macro:

Sub CommentAddOrEditTNR()
'adds TimesNewRoman comment or positions
'cursor at end of existing comment text
  Dim cmt As Comment
  Set cmt = ActiveCell.Comment
  If cmt Is Nothing Then
    ActiveCell.AddComment text:=""
    Set cmt = ActiveCell.Comment
    With cmt.Shape.TextFrame.Characters.Font
      .Name = "Times New Roman"
      .Size = 11
      .Bold = False
      .ColorIndex = 0
    End With
  End If
  SendKeys "%ie~"
End Sub
 

Insert a Comment with Date and Time

To insert a comment with the current date and time, or append the current date and time to an existing comment, use the following macro:

Sub CommentDateTimeAdd()
'adds comment with date and time,
'  positions cursor at end of comment text

    Dim strDate As String
    Dim cmt As Comment
   
    strDate = "dd-mmm-yy hh:mm:ss"
    Set cmt = ActiveCell.Comment
 
    If cmt Is Nothing Then
      Set cmt = ActiveCell.AddComment
      cmt.text text:=Format(Now, strDate) & Chr(10)
    Else
      cmt.text text:=cmt.text & Chr(10) _
        & Format(Now, strDate) & Chr(10)
    End If
   
    With cmt.Shape.TextFrame
      .Characters.Font.Bold = False
    End With
   
    SendKeys "%ie~"

End Sub
 

Reset Comments to Original Position

If comments have moved out of position, you can reset them using the following code:

Sub ResetComments()
Dim cmt As Comment
For Each cmt In ActiveSheet.Comments
   cmt.Shape.Top = cmt.Parent.Top + 5
   cmt.Shape.Left = _
      cmt.Parent.Offset(0, 1).Left + 5
Next
End Sub
 
 

Resize Comments

If comments have changed size, you can reset them using the following code. The first macro resizes all comments on the active sheet, and the second macro resizes all comments in the selected range.

Resize all comments on the active sheet
Sub Comments_AutoSize()
'posted by Dana DeLouis  2000-09-16
  Dim MyComments As Comment
  Dim lArea As Long
  For Each MyComments In ActiveSheet.Comments
    With MyComments
      .Shape.TextFrame.AutoSize = True
      If .Shape.Width > 300 Then
        lArea = .Shape.Width * .Shape.Height
        .Shape.Width = 200
        ' An adjustment factor of 1.1 seems to work ok.
        .Shape.Height = (lArea / 200) * 1.1
      End If
    End With
  Next ' comment
End Sub
 
 

Resize all comments in the selected area
Sub ResizeCommentsInSelection()
'Posted by Dave Peterson 2002-02-25
Dim mycell As Range
Dim myRng As Range
Dim lArea As Long

Set myRng = Selection

For Each mycell In myRng.Cells
  If Not (mycell.Comment Is Nothing) Then
    With mycell.Comment
      .Shape.TextFrame.AutoSize = True
      If .Shape.Width > 300 Then
        lArea = .Shape.Width * .Shape.Height
        .Shape.Width = 200
        .Shape.Height = (lArea / 200) * 1.2
      End If
    End With
  End If
Next mycell
End Sub
 
 

Format All Comments

After you have inserted comments in a workbook, you can use the following code to change the font and font size for all comments in the workbook.

Sub FormatAllComments()
  Dim ws As Worksheet
  Dim cmt As Comment
  For Each ws In ActiveWorkbook.Worksheets
    For Each cmt In ws.Comments
      With cmt.Shape.TextFrame.Characters.Font
        .Name = "Times New Roman"
        .Size = 12
      End With
    Next cmt
  Next ws
End Sub 

Show Comments on Active Sheet

If you choose View|Comments, all comments in all open workbooks will be displayed. Instead, you can use code to show the comments on one sheet, and display the comment indicators only on other sheets.

Sub ShowSheetComments()
'shows all comments on the active sheet
Dim c As Comment

For Each c In ActiveSheet.Comments
  c.Visible = True
Next

End Sub

 

Show Comments in Centre of Active Window

Paste the following code onto a worksheet module. If a cell with a comment is selected on that sheet, its comment is displayed in the centre of the active window's visible range.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

 'www.contextures.com/xlcomments03.html
 Dim rng As Range
 Dim cTop As Long
 Dim cWidth As Long
 Dim cmt As Comment
 Dim sh As Shape
 
 Application.DisplayCommentIndicator _
    = xlCommentIndicatorOnly
 
 Set rng = ActiveWindow.VisibleRange
 cTop = rng.Top + rng.Height / 2
 cWidth = rng.Left + rng.Width / 2
If ActiveCell.Comment Is Nothing Then
  'do nothing
Else
  Set cmt = ActiveCell.Comment
  Set sh = cmt.Shape
  sh.Top = cTop - sh.Height / 2
  sh.Left = cWidth - sh.Width / 2
  cmt.Visible = True
End If

End Sub

 

Copy Comment Text to Adjacent Cell

The following macro will copy comment text to the cell to the right, if that cell is empty.
Sub ShowCommentsNextCell()
'based on code posted by Dave Peterson 2003-05-16
  Application.ScreenUpdating = False

  Dim commrange As Range
  Dim mycell As Range
  Dim curwks As Worksheet
 
  Set curwks = ActiveSheet

  On Error Resume Next
  Set commrange = curwks.Cells _
      .SpecialCells(xlCellTypeComments)
  On Error GoTo 0

  If commrange Is Nothing Then
     MsgBox "no comments found"
     Exit Sub
  End If

  For Each mycell In commrange
     If mycell.Offset(0, 1).Value = "" Then
      mycell.Offset(0, 1).Value = mycell.Comment.Text
     End If
  Next mycell

  Application.ScreenUpdating = True

End Sub 

Copy Comments to Another Worksheet

The following macro will add a sheet to the workbook, with a list of comments, including the cell address, and cell name, if any.

 

Sub showcomments()
'posted by Dave Peterson 2003-05-16
    Application.ScreenUpdating = False

    Dim commrange As Range
    Dim mycell As Range
    Dim curwks As Worksheet
    Dim newwks As Worksheet
    Dim i As Long

    Set curwks = ActiveSheet

    On Error Resume Next
    Set commrange = curwks.Cells _
        .SpecialCells(xlCellTypeComments)
    On Error GoTo 0

    If commrange Is Nothing Then
       MsgBox "no comments found"
       Exit Sub
    End If

    Set newwks = Worksheets.Add

     newwks.Range("A1:D1").Value = _
         Array("Address", "Name", "Value", "Comment")

    i = 1
    For Each mycell In commrange
       With newwks
         i = i + 1
         On Error Resume Next
         .Cells(i, 1).Value = mycell.Address
         .Cells(i, 2).Value = mycell.Name.Name
         .Cells(i, 3).Value = mycell.Value
         .Cells(i, 4).Value = mycell.Comment.Text
       End With
    Next mycell

    Application.ScreenUpdating = True

End Sub 

Copy Comments from All Sheets to Another Worksheet

The following macro will add a sheet to the workbook, with a list of comments from all sheets in the workbook, including the sheet name, cell address, and cell name, if any.

Sub ShowCommentsAllSheets()
'modified from code
'posted by Dave Peterson 2003-05-16
  Application.ScreenUpdating = False

  Dim commrange As Range
  Dim mycell As Range
  Dim ws As Worksheet
  Dim newwks As Worksheet
  Dim i As Long

Set newwks = Worksheets.Add

 newwks.Range("A1:E1").Value = _
     Array("Sheet", "Address", "Name", "Value", "Comment")
    
For Each ws In ActiveWorkbook.Worksheets
  On Error Resume Next
  Set commrange = ws.Cells.SpecialCells(xlCellTypeComments)
  On Error GoTo 0

  If commrange Is Nothing Then
    'do nothing
  Else
 
    i = newwks.Cells(Rows.Count, 1).End(xlUp).Row

    For Each mycell In commrange
       With newwks
         i = i + 1
         On Error Resume Next
         .Cells(i, 1).Value = ws.Name
         .Cells(i, 2).Value = mycell.Address
         .Cells(i, 3).Value = mycell.Name.Name
         .Cells(i, 4).Value = mycell.Value
         .Cells(i, 5).Value = mycell.Comment.text
       End With
    Next mycell
  End If
  Set commrange = Nothing
Next ws
 
'format cells for no wrapping, remove line break
newwks.Cells.WrapText = False
newwks.Columns("E:E").Replace What:=Chr(10), _
  Replacement:=" ", LookAt:=xlPart, _
  SearchOrder:=xlByRows, MatchCase:=False, _
  SearchFormat:=False, ReplaceFormat:=False

Application.ScreenUpdating = True

End Sub 

Copy Comments to Microsoft Word

The following code copies the comment text from the active sheet, and adds it to a Microsoft Word document, along with the cell address.

Sub CopyCommentsToWord()

  Dim cmt As Comment
  Dim WdApp As Object

  On Error Resume Next
  Set WdApp = GetObject(, "Word.Application")
  If Err.Number <> 0 Then
    Err.Clear
    Set WdApp = CreateObject("Word.Application")
  End If

  With WdApp
    .Visible = True
    .Documents.Add DocumentType:=0

    For Each cmt In ActiveSheet.Comments
      .Selection.TypeText cmt.Parent.Address _
                            & vbTab & cmt.Text
      .Selection.TypeParagraph
    Next
  End With

  Set WdApp = Nothing

End Sub 
             

Print Worksheet with Comment Indicators

When you print a worksheet that contains comments, the comment indicators are not visible. There is no option to change this behaviour. As a workaround, you can draw triangle AutoShapes over the comment indicators.

Draw Triangular AutoShapes over the Comment Indicators

The following code will draw a triangular AutoShape over each comment indicator on the active sheet:

Sub CoverCommentIndicator()
Dim ws As Worksheet
Dim cmt As Comment
Dim rngCmt As Range
Dim shpCmt As Shape
Dim shpW As Double 'shape width
Dim shpH As Double 'shape height

Set ws = ActiveSheet
shpW = 6
shpH = 4

For Each cmt In ws.Comments
  Set rngCmt = cmt.Parent
  With rngCmt
    Set shpCmt = ws.Shapes.AddShape(msoShapeRightTriangle, _
      rngCmt.Offset(0, 1).Left - shpW, .Top, shpW, shpH)
  End With
  With shpCmt
    .Flip msoFlipVertical
    .Flip msoFlipHorizontal
    .Fill.ForeColor.SchemeColor = 10 'Red
           '12=Blue, 57=Green
    .Fill.Visible = msoTrue
    .Fill.Solid
    .Line.Visible = msoFalse
  End With
Next cmt

End Sub

Remove Triangular AutoShapes over the Comment Indicators

The following code will remove the triangular AutoShape over each comment indicator on the active sheet:
Sub RemoveIndicatorShapes()

Dim ws As Worksheet
Dim shp As Shape

Set ws = ActiveSheet

For Each shp In ws.Shapes
If Not shp.TopLeftCell.Comment Is Nothing Then
  If shp.AutoShapeType = _
    msoShapeRightTriangle Then
    shp.Delete
  End If
End If
Next shp

End Sub 
             
 

 

Number and List Comments

When you print a worksheet that contains comments, you can use programming to number the comments. List the numbered comments on a separate sheet, and print them.

Download the zipped sample file for numbered comments: CommentsNumberPrint.zip

Draw Numbered Rectangles over the Comment Indicators

The following code will draw a numbered rectangle AutoShape over each comment indicator on the active sheet:

Sub CoverCommentIndicator()
Dim ws As Worksheet
Dim cmt As Comment
Dim lCmt As Long
Dim rngCmt As Range
Dim shpCmt As Shape
Dim shpW As Double 'shape width
Dim shpH As Double 'shape height

Set ws = ActiveSheet
shpW = 8
shpH = 6
lCmt = 1

For Each cmt In ws.Comments
  Set rngCmt = cmt.Parent
  With rngCmt
    Set shpCmt = ws.Shapes.AddShape(msoShapeRectangle, _
      rngCmt.Offset(0, 1).Left - shpW, .Top, shpW, shpH)
  End With
  With shpCmt
    With .Fill
      .ForeColor.SchemeColor = 9 'white
      .Visible = msoTrue
      .Solid
    End With
    With .Line
      .Visible = msoTrue
      .ForeColor.SchemeColor = 64 'automatic
      .Weight = 0.25
    End With
    With .TextFrame
      .Characters.Text = lCmt
      .Characters.Font.Size = 4
      .MarginLeft = 0#
      .MarginRight = 0#
      .MarginTop = 0#
      .MarginBottom = 0#
    .HorizontalAlignment = xlCenter
    End With
  End With
  lCmt = lCmt + 1
Next cmt

End Sub

Remove Rectangular AutoShapes over the Comment Indicators

The following code will remove the rectangular AutoShape over each comment indicator on the active sheet:
Sub RemoveIndicatorShapes()

Dim ws As Worksheet
Dim shp As Shape

Set ws = ActiveSheet

For Each shp In ws.Shapes
If Not shp.TopLeftCell.Comment Is Nothing Then
  If shp.AutoShapeType = _
    msoShapeRectangle Then
    shp.Delete
  End If
End If
Next shp

End Sub 

List Comments on New Sheet

The following code will list the numbered comments on a new worksheet:
Sub showcomments()
'posted by Dave Peterson 2003-05-16
    Application.ScreenUpdating = False

    Dim commrange As Range
    Dim mycell As Range
    Dim curwks As Worksheet
    Dim newwks As Worksheet
    Dim i As Long

    Set curwks = ActiveSheet

    On Error Resume Next
    Set commrange = curwks.Cells _
        .SpecialCells(xlCellTypeComments)
    On Error GoTo 0

    If commrange Is Nothing Then
       MsgBox "no comments found"
       Exit Sub
    End If

    Set newwks = Worksheets.Add

     newwks.Range("A1:D1").Value = _
         Array("Number", "Name", "Value", "Comment")

    i = 1
    For Each mycell In commrange
       With newwks
         i = i + 1
         On Error Resume Next
         .Cells(i, 1).Value = i - 1
         .Cells(i, 2).Value = mycell.Name.Name
         .Cells(i, 3).Value = mycell.Value
         .Cells(i, 4).Value = Replace(mycell.Comment.Text, Chr(10), " ")
       End With
    Next mycell
    newwks.Cells.WrapText = False
    newwks.Columns.AutoFit

    Application.ScreenUpdating = True

End Sub 

             
 

 

Insert Selected Picture Into Comment

The following code creates a file from the selected picture, inserts it into a comment in the active cell, and deletes the picture. Download the zipped sample file.

Sub PictureIntoComment()
Dim ch As ChartObject
Dim dWidth As Double
Dim dHeight As Double
Dim ws As Worksheet
Dim sName As String
Dim cmt As Comment
Dim sPath As String
Dim sFile As String
Dim rng As Range
Set ws = ActiveSheet
Set rng = ActiveCell
sPath = ThisWorkbook.Path & "\"
sName = InputBox("Name for picture file (no extension)", "File Name")
If sName = "" Then sName = "Picture_" & Format(Date, "yyyymmdd")
sFile = sPath & sName & ".gif"

    dWidth = Selection.Width
    dHeight = Selection.Height
   
    Selection.Cut
    Set ch = ws.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, _
      Width:=dWidth, Height:=dHeight)
    ch.Chart.Paste
    rng.Activate
    ch.Chart.Export sFile
    ch.Delete
    Set cmt = rng.AddComment
    cmt.Text Text:=""
    With cmt.Shape
      .Fill.UserPicture sFile
      .Width = dWidth
      .Height = dHeight
    End With

End Sub