macro trouble

[jen_writer]

Hi,
I copied the two macros below from http://contextures.com/xlcomments03.html.
one macro places numbers over the triangles of my comments and the other
lists the comments on a separate worksheet. I wanted this so that I could
print both out and be able to refer to the comment list when looking at the
printed spreadsheet. however, the list doesn't match up with the numbers
covering the comment triangles on the spreadsheet. Can anyone help me with
this?

thanks
Jen

MACRO TO NUMBER COMMENTS
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


MACRO TO LIST COMMENTS

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("A11").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

 

[Dave Peterson]

Your code worked ok for me.

But maybe naming the rectangles would be better???

Option Explicit

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

ws.Rectangles.Delete
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)
shpCmt.Name = "CMT_" & rngCmt.Address(0, 0)
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


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("A11").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 _
= mycell.Parent.Rectangles("CMT_" & mycell.Address(0, 0)).Text
.Cells(i, 2).Value = mycell.Name.Name
.Cells(i, 3).Value = mycell.Value
.Cells(i, 4).Value = Replace(mycell.Comment.Text, Chr(10), " ")
on error goto 0
End With
Next mycell
newwks.Cells.WrapText = False
newwks.Columns.AutoFit

Application.ScreenUpdating = True

End Sub