Numbering Comments

[ttratl]

Hi Everyone,

I have this code in Module 1 of my workbook:

Option Explicit
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

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
    .Top = .Top + 0.001
  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 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:D1").Value = _
         Array("Number", "Name", "Value", "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

These macros insert a numbered rectangle over the red comment flags (so you can see the cells with comments when printing), remove the numbered rectangles, and the 3rd macro lists all the comments on a seperate worksheet.
They all work fine in the downloaded file from Contextures, but in my workbook the 'remove rectangles' code fails at

If Not shp.TopLeftCell.Comment Is Nothing Then

Any ideas why this should happen?
I have the code in Module 1, because that's where it is in the working file. I don't have any other code running in this file. I'm baffled!

 

[ttratl]

Hi Andrew,

This works fine with the control file, with DV on the worksheet.
When I run it on my worksheet - it removes the comment indicators on most, but not all, the cells, then crashes Excel. (I get that dialog that asks to send error report data to MS)

 

[Andrew Poulsom]

Sorry, I don't know why that would be.

 

[ttratl]

Hi Andrew,

Success!! Haven't a clue why this worked but I have completely rebuilt the spreadsheet from new, replaced the offending code with your 'Test' code, and voila - it works!

I can't see any difference from the original. I have all the code in the same places, so it's a mystery.

Thought you'd like to know - thanks very much for your help.