Search Contextures Sites

Contextures
Excel news
by email

We respect your email privacy

 

 

Learn how to create Excel dashboards.

 

30 Excel Functions in 30 Days

 

Learn how to create Excel dashboards.

 

 

 

Learn how to create Excel dashboards.

 

 

Time-saving
Pivot Table add-in

 

Excel Comments VBA

You can add any of the following macros to a workbook that opens automatically when Excel opens (e.g. Personal.xls), then add a toolbar button or shortcut key to run it.

Change the User Name
Insert a Plain Comment
Insert a Formatted Comment  
Insert a Colour Formatted Comment  
Insert Excel Comments with Date and Time  
Replace Old Name in Excel Comments
Reset Comments to Original Position 
Resize Excel Comments 
Format All Excel Comments 
Show Comments on Active Sheet  
Show Excel Comments in Centre of Active Window  
Show Excel Comments at Right of Active Window
Copy Comment Text to Adjacent Cell  
Copy Comments to Another Worksheet
Copy Comments from All Sheets to Another Worksheet
Copy Excel Comments to Microsoft Word
Print Comments with Indicators  
Number and List Excel Comments  
List Numbered Comments With Merged Cells
Create Excel Comments with Pictures From File List  
Insert Selected Picture Into Comment  

Change the User Name

Instead of showing the user name at the start of Excel comments, 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.

Database

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

To reset the User Name in Excel comments:     
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.

Database

Sub CommentAddOrEdit()
'adds new plain text comment or positions
'cursor at end of existing comment text
'www.contextures.com\xlcomments03.html
  Dim cmt As Comment
  Set cmt = ActiveCell.Comment
  If cmt Is Nothing Then
    ActiveCell.AddComment text:=""
  End If
  SendKeys "+{F2}"
End Sub

To avoid use of the SendKeys command, you can use the following variation, which leaves the Excel 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 Excel 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.

Database

The following macro will replace the old name with a new name.

Sub ChangeCommentName()
'replaces old names in Excel comments
'deletes and reinserts Excel comments
'  so new name appears in status bar
'www.contextures.com\xlcomments03.html
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 Excel comments with no User Name, formatted in Times New Roman font, use the following macro, which uses the SendKeys method:

Database

Sub CommentAddOrEditTNR()
'adds TimesNewRoman comment or positions
'cursor at end of existing comment text
'www.contextures.com\xlcomments03.html
  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 "+{F2}"
End Sub


Insert a Colour Formatted Comment

To insert a comment with no User Name, formatted with red text in the first line, blue text in the second line, and bold text after the colons, use the following macro:

Database

Sub CommentTextFormatColour()
'adds comment then formats font colour and adds bold
'www.contextures.com\xlcomments03.html
  Dim cmt As Comment
  Dim str1 As String
  Dim str2 As String
  Dim lBreak As Long
  Dim lNum1 As Long
  Dim lNum2 As Long
  Dim lNumLen As Long
  Dim strFind As String
  On Error Resume Next
  
  str1 = "John: 20 Eggs"
  str2 = "Simon: 50 Eggs"
  strFind = ":"
  lNumLen = 3
  
  Set cmt = ActiveCell.Comment
  If cmt Is Nothing Then
    ActiveCell.AddComment _
      text:=str1 & Chr(10) & str2
    Set cmt = ActiveCell.Comment
  End If
    
  'find the line break and markers
  lBreak = InStr(1, cmt.text, Chr(10))
  lNum1 = InStr(1, cmt.text, strFind) + 1
  lNum2 = InStr(lBreak, cmt.text, strFind) + 1
  
  'format the lines of text
  With cmt.Shape.TextFrame
    .Characters(1, lBreak).Font.ColorIndex = 3
    .Characters(lBreak + 1, Len(cmt.text)).Font.ColorIndex = 5
  End With
  
  'add bold to numbers that follow colon
  If lNum1 > 0 Then
    With cmt.Shape.TextFrame
      .Characters.Font.Bold = False
      .Characters(lNum1, lNumLen).Font.Bold = True
      .Characters(lNum2, lNumLen).Font.Bold = True
    End With
  End If
  SendKeys "+{F2}"  'opens comment for editing
  'SendKeys "%ie~"  'works with Excel 2003 menu
End Sub


Insert Excel Comments with Date and Time

To insert Excel comments with the current date and time, or append the current date and time to an existing comment, use the following macro. It uses the SendKeys method:

Database

Sub CommentDateTimeAdd()
'adds Excel comments with date and time, 
'  positions cursor at end of comment text
'www.contextures.com\xlcomments03.html

    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 "+{F2}"  'opens comment for editing

End Sub


Reset Comments to Original Position

If Excel 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 Excel Comments

If Excel 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 Excel 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()
'www.contextures.com\xlcomments03.html
  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 Excel comments on one sheet, and display the comment indicators only on other sheets.

Database

Sub ShowSheetComments()
'www.contextures.com\xlcomments03.html
'shows all comments on the active sheet
Dim c As Comment

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

End Sub

Show Excel 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.

Database

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

Show Excel Comments at Right 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 at the far right of the active window's visible range. A bit of space is added (lGap) to allow for scroll bar on the right side.

Database

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 'www.contextures.com/xlcomments03.html
 'show comments at centre right of window
 Dim rng As Range
 Dim cTop As Long
 Dim lGap As Long
 Dim cmt As Comment
 Dim sh As Shape
 
 Application.DisplayCommentIndicator _
    = xlCommentIndicatorOnly
 
 Set rng = ActiveWindow.VisibleRange
 cTop = rng.Top + rng.Height / 2
 lGap = 30 'adjust space between window edge and comment
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 = rng.Width - sh.Width - lGap
  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.

Database

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 Excel 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 Excel 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.

Database

Sub CopyCommentsToWord()
'www.contextures.com\xlcomments03.html

  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.

Database

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()
'www.contextures.com\xlcomments03.html
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()
'www.contextures.com\xlcomments03.html

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 Excel 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 in Excel 2003 and earlier versions: CommentsNumberPrint.zip 

NOTE: Code is slightly different for Excel 2007. Please use this file: CommentNumbersPrint2007.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()
'www.contextures.com\xlcomments03.html
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
    .Name = "CmtNum" & .Name
    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 = 5
      .Characters.Font.ColorIndex = xlAutomatic
      .MarginLeft = 0#
      .MarginRight = 0#
      .MarginTop = 0#
      .MarginBottom = 0#
    .HorizontalAlignment = xlCenter
    End With
    .Top = .Top + 0.001
  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()
'www.contextures.com\xlcomments03.html

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 Left(shp.Name, 6) = "CmtNum" 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. If there are merged cells with comments, use the code in the next section.

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

    Dim commrange As Range
    Dim cmt As Comment
    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:E1").Value = _
         Array("Number", "Name", "Value", "Address", "Comment")

    i = 1
    For Each cmt In curwks.Comments
       With newwks
         i = i + 1
         On Error Resume Next
         .Cells(i, 1).Value = i - 1
         .Cells(i, 2).Value = cmt.Parent.Name.Name
         .Cells(i, 3).Value = cmt.Parent.Value
         .Cells(i, 4).Value = cmt.Parent.Address
         .Cells(i, 5).Value = Replace(cmt.Text, Chr(10), " ")
       End With
    Next cmt

    newwks.Cells.WrapText = False
    newwks.Columns.AutoFit

    Application.ScreenUpdating = True

End Sub

List Numbered Comments With Merged Cells

The following code will create a numbered list comments on a new worksheet. To add numbers in the cells, use the CoverCommentIndicator code in the previous section.

The sample code is in this Excel 2007 format file: CommentNumbersPrint2007.zip  

Sub showcomments_formerged()
'based on code 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
Dim rowTop As Long
Dim colFirst As Long
Dim colLast As Long
Dim bMerge As Boolean

    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:E1").Value = _
         Array("Number", "Name", "Value", "Address", "Comment")

    i = 1
    For Each mycell In commrange
      If mycell.MergeCells Then
        bMerge = True
        colFirst = mycell.MergeArea.Columns(1).Column
        colLast = mycell.MergeArea.Columns(mycell.MergeArea.Columns.Count).Column
        rowTop = mycell.MergeArea.Rows(1).Row
      Else
        colFirst = mycell.Column
        colLast = mycell.Column
        rowTop = mycell.Row
      End If
      
      If mycell.Row = rowTop _
            And mycell.Column = colLast Then
        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 = curwks.Cells(rowTop, colFirst).Value
          curwks.Cells(rowTop, colFirst).Copy
          .Cells(i, 3).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
          .Cells(i, 4).Value = mycell.Address
          .Cells(i, 5).Value = Replace(curwks.Cells(rowTop, colFirst).Comment.Text, Chr(10), " ")
        End With
      End If
    
    Next mycell
    
    newwks.Cells.WrapText = False
    newwks.Columns.AutoFit

    Application.ScreenUpdating = True

End Sub

Create Excel Comments with Pictures From File List

The following code creates a comment with picture inserted, in column B, based on a file list in column A. Download the zipped sample file.

Comment Picture

Sub InsertComment()
'www.contextures.com\xlcomments03.html
Dim rngList As Range
Dim c As Range
Dim cmt As Comment
Dim strPic As String
    
On Error Resume Next

Set rngList = Range("A1:A5")
strPic = "C:\Data\"

For Each c In rngList
  With c.Offset(0, 1)
    Set cmt = c.Comment
    If cmt Is Nothing Then
      Set cmt = .AddComment
    End If
    With cmt
      .Text Text:=""
      .Shape.Fill.UserPicture strPic & c.Value
      .Visible = False
    End With
  End With
Next c
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.

Comment Picture

Sub PictureIntoComment()
'www.contextures.com\xlcomments03.html
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

Related Tutorials

       Home     Excel Tips     Excel Files     The Excel Store     Blog     Contact

 

Privacy Policy

 

Contextures Inc., Copyright ©2013
All rights reserved.

 

Last updated: January 23, 2013 4:45 PM