Public Sub ReplaceOccurance()
Dim oAssDoc As Inventor.AssemblyDocument
Set oAssDoc = ThisApplication.ActiveDocument
Dim oAssCompDef As Inventor.AssemblyComponentDefinition
Set oAssCompDef = oAssDoc.ComponentDefinition
Dim oAssOccurences As Inventor.ComponentOccurrences
Set oAssOccurences = oAssCompDef.Occurrences
Dim oCompOccur As Inventor.ComponentOccurrence
For Each oCompOccur In oAssOccurences
MsgBox oCompOccur.Name
'Either you can use the name of the occurence or the index of the occurence
'to replace a particular occurence by a different part or sub assembly
'Please note that if the second parameter is true and the same occurence has multiple instances
'i.e. a car has four wheels, and if the replace is called on any of the wheel occurence with
'second parameter true, all the wheels will be replaced otherwise only that instance
'will be replaced on which will be called.
If oCompOccur.Name = "MYOCCURANCE" Then
Call oCompOccur.Replace("C:\Myoccorence.ipt", False)
End If
'If the occurence is attached by imate and the replacing part or assembly does not have the
'correct imate then the imates will fail
Next
End Sub
In this sample I have used the name of the occurence to replace one. You can use the index too. The indexing is same as the position in the browser pan. For useing the index you need to change the for loop as follows
Dim i As Long
For i = 1 To oAssOccurences.Count
Set oCompOccur = oAssOccurences(i)
Select Case i
Case 1:
'replace at index 1
Case 2:
'replace at index 2
Case Else:
'replace default
End Select
Next
Hope this will help you problem
Manoj
Wednesday, March 13, 2019
Excel Comments - Macros
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.
To set a generic label in comments:
Sub CommentNote()
Application.UserName = "Note"
End Sub
To reset the User Name in 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.
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
'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 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 - No Pictures
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.
NOTE: This creates new comments, without the original formatting. If you need to copy comment pictures, or other formatting, use the macro in the next section - Replace Names With Pictures
Sub ChangeCommentName()
'replaces old names in comments
'deletes and reinserts 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
Replace Old Name in Comments - With Pictures
This macro is similar to the one above -- it replaces the old names attached to cell comments. However, this macro also copies the old comment formatting. Use this if you want to copy pictures, or other formatting, from the original comments.
This macro will be a bit slower, so use the Replace Name No Pictures macro if you're not concerned about formatting. It adds a temporary worksheet, pastes the old comment there, and copies the formatting to the new comment.
Sub ChangeCommentNameKeepPicture()
'replaces old names in comments
'deletes and reinserts comments
' so new name appears in status bar
'also copies pictures and other formatting
'www.contextures.com/xlcomments03.html
Dim ws As Worksheet
Dim wsTemp As Worksheet
Dim rngTempOld As Range
Dim rngTempNew As Range
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
Dim strCmtText As String
Dim cmtOld As Comment
Dim cmtNew As Comment
Dim lCmtShow As Long
On Error Resume Next
Application.DisplayAlerts = False
lCmtShow = Application.DisplayCommentIndicator
'show the comments
Application.DisplayCommentIndicator = xlCommentAndIndicator
Application.ScreenUpdating = False
Set ws = ActiveSheet
Set wsTemp = Sheets.Add
Set rngTempOld = wsTemp.Range("A1")
Set rngTempNew = wsTemp.Range("A2")
For Each cmtOld In ws.Comments
strCmtText = Replace(cmtOld.Text, strOld, strNew)
cmtOld.Parent.Copy
rngTempOld.PasteSpecial xlPasteComments
Set cmtNew = rngTempNew.AddComment
cmtNew.Text Text:=strCmtText
rngTempOld.Comment.Visible = True
rngTempNew.Comment.Visible = True
rngTempOld.Comment.Shape.Select
Selection.ShapeRange.PickUp
rngTempNew.Comment.Shape.Select
Selection.ShapeRange.Apply
cmtOld.Delete
rngTempNew.Copy
cmtOld.Parent.PasteSpecial Paste:=xlPasteComments
rngTempOld.Clear
rngTempNew.Clear
Next cmtOld
ws.Activate
wsTemp.Delete
Application.UserName = strOld
Application.DisplayCommentIndicator = lCmtShow
Application.ScreenUpdating = True
End Sub
Insert a Formatted Comment
To insert comments with no User Name, formatted in Times New Roman font, use the following macro, which uses the SendKeys method:
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:
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 comments with Date and Time
To insert 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:
Sub CommentDateTimeAdd()
'adds 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
'opens comment for editing
SendKeys "+{F2}"
End Sub
Reset Comments to Original Position
If comments have moved out of position, you can reset them using the following code:
NOTE: This feature is available in my Contextures Excel Tools add-in
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 methods are not perfect, but are useful for cleaning up many comments that have changed size.
- Macro 1 resizes all comments on the active sheet, based on the area of the AutoSized comment
- Macro 2 resizes all comments in the selected range, based on the area of the AutoSized comment
- Macro 3 resizes all comments in the selected range, based on the row height of a test cell
NOTE: Comment resizing is available in my Contextures Excel Tools add-in
1 - Resize all comments on the active sheet (based on AutoSize area)
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
2 - Resize all comments in the selected area (based on AutoSize 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
3 - Resize all comments in the selected area (based on test cell height)
Sub ResizeCommentsInSelectionRH()
'www.contextures.com
'resize comments based on row height
'of test cells where text was copied
Dim lMinWidth As Long
Dim lMaxWidth As Long
Dim lWidth As Long
Dim dblMult As Double
Dim dblMultH As Double
Dim mycell As Range
Dim myRng As Range
Dim strText As String
Dim dColW As Double
Dim dColCW As Double
Dim lHeight As Long
Dim lChar As Long
Dim lCount As Long
Dim lBreak As Long
Dim sh As Shape
Dim strAdd As String
Dim wsTemp As Worksheet
Dim dMaxWPt As Double
'.columnwidth/.width
Dim dRatio As Double
'.columnwidth for test
Dim dCWTest As Double
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'On Error Resume Next
Select Case CDbl(Application.Version)
Case Is > 14
strAdd = " "
Case Else
strAdd = ""
End Select
Set myRng = Intersect(Selection, _
ActiveSheet.UsedRange)
Set wsTemp = Worksheets.Add
If Not wsTemp Is Nothing Then
lMinWidth = _
InputBox("Which comments should be resized?" _
& vbCrLf & "Width greater than:", _
"Resize Sheet Comments", 1)
If lMinWidth = 0 Then
MsgBox "Width must be 1 or greater"
Exit Sub
End If
lMaxWidth = InputBox("What should be the new comment width?", _
"Resize Sheet Comments", 300)
If lMaxWidth = 0 Then
MsgBox "Width must be 1 or greater"
Exit Sub
End If
dblMultH = _
InputBox("What multiplier should be used for Height?", _
"Resize Sheet Comments", 1#)
If dblMultH = 0 Then
Exit Sub
End If
'.Width property uses points
' 96 pixels to 72 points
dblMult = 72 / 96
'desired comment width in points
dMaxWPt = lMaxWidth * dblMult
'.ColumnWidth property shows
'number of characters
'One unit of column width =
'width of one character in Normal style
'For proportional fonts, the width of
' the character 0 (zero) is used.
dCWTest = 100 '.columnwidth for test
With wsTemp.Columns(1)
.ColumnWidth = dCWTest
'get ratio of .columnwidth (char)
' to .width property (points)
dRatio = .Width / dCWTest
'multiply desired width by test ratio
' for .ColumnWidth setting
.ColumnWidth = dMaxWPt / dRatio
End With
For Each mycell In myRng.Cells
If Not (mycell.Comment Is Nothing) Then
Set sh = mycell.Comment.Shape
If sh.Width > lMinWidth Then
lChar = sh.TextFrame.Characters.Count
With wsTemp
.Range("A1:A3").ClearContents
If lChar <= 255 Then
.Range("A1").Value _
= sh.TextFrame.Characters.Text
Else
For lCount = 1 To lChar Step 250
Select Case lCount
Case Is <= 250 * 3
.Range("A1").Value = .Range("A1").Value _
& sh.TextFrame.Characters(Start:=lCount, _
Length:=250).Text & strAdd
Case Is <= 250 * 6
.Range("A2").Value = .Range("A2").Value _
& sh.TextFrame.Characters(Start:=lCount, _
Length:=250).Text & strAdd
Case Else
.Range("A3").Value = .Range("A3").Value _
& sh.TextFrame.Characters(Start:=lCount, _
Length:=250).Text & strAdd
End Select
Next lCount
End If
.Range("A1:A3").Font.Name = _
sh.TextFrame.Characters.Font.Name
.Range("A1:A3").Font.Size = _
sh.TextFrame.Characters.Font.Size
.Range("A1:A3").WrapText = True
.Rows("1:3").AutoFit
Select Case lChar
Case Is <= 250 * 3
lHeight = .Rows(1).Height
Case Is <= 250 * 6
lHeight = .Rows("1:2").Height
Case Else
lHeight = .Rows("1:3").Height
End Select
End With
With sh
.Height = lHeight * dblMult * dblMultH
.Width = lMaxWidth
End With
End If
End If
Next mycell
wsTemp.Delete
Else
MsgBox "Could not add temporary sheet." _
& vbCrLf _
& "Please unprotect workbook structure" _
& vbCrLf _
& " and try again."
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
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()
'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 comments on one sheet, and display the comment indicators only on other sheets.
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 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
Show 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.
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.
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()
'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.
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 comments
Before you print a worksheet that contains comments, you can use programming to number the comments, and then list the numbered comments on a separate sheet, and print them.
After you print the sheet, run another macro to remove the numbered shapes that were added to each comment cell.
Running the Numbered Comments Code
There are 3 parts to the code:
- Draw the numbered rectangles
- Remove the numbered rectangles:
- List the numbered comments:
- For sheets without merged cell comments
- For sheets with merged cell comments
To use the code, copy the code samples below, and paste them into a regular module in your workbook. OR, download the sample workbook, and copy the code from there.
Draw Numbered Rectangles over Comment Indicators
The following code draws 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 Numbered Rectangles over Comment Indicators
The following code will remove the rectangular AutoShape over each comment indicator on the active sheet. Run this code when you no longer need the numbered shapes:
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 instead of this code.
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 Comments - 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.
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
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 to create a comment with a picture from a file list.
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.
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
Download the Sample Files
- 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 - Download the sample file with Comment Resizer code -- resize comments in selected range, by area or resize by test cell row height. The zipped file is in xlsm format, and contains macros.
- Download the zipped sample file to create a comment with a picture from a file list.
- Download the zipped sample file to create a file from the selected picture and insert it into a comment in the active cell.
- Download the zipped sample file for numbered comments:
- For Excel 2007 and later versions (includes code for merged cells):CommentNumbersPrint2007.zip
- For Excel 2003 and earlier: CommentsNumberPrint.zip
Related Tutorials
Subscribe to:
Posts (Atom)