VBA to resize comments on selected range instead of whole sheet-CodePudding

I am using the following code to auto resize comments (notes) in my excel spread sheet. However my sheet is very large and the code works but is slow. To speed it up I wish to specify a smaller range that it works on as I do not need it to work on the whole sheet. Lets say cells A1 to B10. Does Any one know how I can do this? See my code below

Thanks in Advance rockingmark

Sub NotesResize()


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

I have tried setting ranges as follows, but I get Run time error '438': Object doesn't support this property or method. Hopefully someone knows a better way that works?

Sub NotesResizeSelection()

Dim MyComments As Comment
Dim lArea As Long
Dim rng2 As Range
Set rng2 = Range("A1:B10")

For Each MyComments In rng2.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

CodePudding user response：

the range object does not have a collection of comments so your call to rng2.Comments is invalid, hence the error. Comments is a property of the Worksheet object.

What you could do is verify if the active comment is in the selected range? Though this would still loop through all the comments?

Like below:

Sub NotesResizeSelection()

Dim MyComments As Comment
Dim lArea As Long
Dim rng2 As Range
Set rng2 = Range("A1:B10")

minRow = rng2.row
maxRow = minRow   rng2.Rows.Count - 1
minColumn = rng2.Column
maxColumn = minColumn   rng2.columns.Count - 1

For Each Comment In ActiveSheet.Comments
    cRow = Comment.Parent.row
    cCol = Comment.Parent.Column
    If (cRow >= minRow And cRow <= maxRow) And (cCol >= minColumn And cCol <= maxColumn) Then
        With Comment
          .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
    End If
Next ' comment
End Sub

Alternatively you could loop through all the Cells of the range and determine if cell.Comment Is Not Nothing and then set the relevant comment if it is not nothing.

Though arguably if this would be faster than working on each comment?

You could contemplate trying to set Application.Screenupdating = false but that can be tricky. (see also my answer here: Screen Updating)