Speed Up Working With Comments in Excel VBA

问题

This is an example I contrived, I created this to explain the problem I'm having. Basically I want this code to run faster than it does. On a new sheet each loop of a cell starts fast, but if you let it run to near completion, and then run it again, it will hit 100ms per cell. In my sheet I have 16000 cells with a lot of comments like this, and they are manipulated individually every time the code runs. In this example they are obviously all the same, but in the real application each one is different.

Is there anyway to make this process faster?

Option Explicit
Public Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long
Public Sub BreakTheCommentSystem()
Dim i As Integer
Dim t As Long
Dim Cell As Range
Dim dR As Range
Set dR = Range(Cells(2, 1), Cells(4000, 8))

Dim rStr As String
rStr = "ABCDEFG HIJK LMNOP QRS TUV WX YZ" & Chr(10)

For i = 1 To 5
    rStr = rStr & rStr
Next i

For Each Cell In dR
    t = GetTickCount
    With Cell
        If .Comment Is Nothing Then
            .AddComment
        Else
            With .Comment
                With .Shape.TextFrame.Characters.Font
                    .Bold = True
                    .Name = "Arial"
                    .Size = 8
                End With
                .Shape.TextFrame.AutoSize = True
                .Text rStr
            End With
        End If

    End With
    Debug.Print (GetTickCount - t & " ms ")
Next

rStr = Empty
i = Empty
t = Empty
Set Cell = Nothing
Set dR = Nothing


End Sub

Update 12-11-2015, I wanted this noted somewhere in case anyone runs into it, the reason I was trying to optimize this so much was because VSTO would not let me add a workbook file with all these comments. After 6 months of working with Microsoft, this is now a confirmed bug in the VSTO and Excel.

https://connect.microsoft.com/VisualStudio/feedback/details/1610713/vsto-hangs-while-editing-an-excel-macro-enabled-workbook-xlsm-file

回答1:

According to the MSDN Comments collection and Comment object documentation, you can reference all comments within a worksheet through their indexed position and deal with them directly rather than cycle through each cell and determine whether it contains a comment.

Dim c As Long
With ActiveSheet    '<- set this worksheet reference properly!
    For c = 1 To .Comments.Count
        With .Comments(c)
            Debug.Print .Parent.Address(0, 0)  ' the .parent is the cell containing the comment
            ' do stuff with the .Comment object
        End With
    Next c
End With

Also according to official docs for the Range.SpecialCells method you can easily determine a subset of cells in a worksheet using the xlCellTypeComments constant as the Type parameter.

Dim comcel As Range
With ActiveSheet    '<- set this worksheet reference properly!
    For Each comcel In .Cells.SpecialCells(xlCellTypeComments)
        With comcel.Comment
            Debug.Print .Parent.Address(0, 0)  ' the .parent is the cell containing the comment
            ' do stuff with the .Comment object
        End With
    Next comcel
End With

I'm still unclear with the reasoning behind filling all non-commented cells with a blank comment but if you are trying to work with the comments only on a worksheet it is better to work with the subset of commented cells rather than cycling through all cells looking for a comment.

回答2:

By turning off screen updating, I was able to reduce the time for each iteration from around 100ms to around 17ms. You can add the following to the start of the procedure:

Application.ScreenUpdating = False

You can turn updating back on at the end of the procedure by setting it back to true.

回答3:

This code copies the data to a new worksheet, and recreates all notes:

In a new user module:

---

Option Explicit

Private Const MAX_C     As Long = 4000
Private Const MAIN_WS   As String = "Sheet1"
Private Const MAIN_RNG  As String = "A2:H" & MAX_C
Private Const MAIN_CMT  As String = "ABCDEFG HIJK LMNOP QRS TUV WX YZ"

Public Sub BreakTheCommentSystem_CopyPasteAndFormat()
    Dim t As Double, wsName As String, oldUsedRng As Range
    Dim oldWs As Worksheet, newWs As Worksheet, arr() As String

    t = Timer
    Set oldWs = Worksheets(MAIN_WS)
    wsName = oldWs.Name
UpdateDisplay False
    RemoveComments oldWs
    MakeComments oldWs.Range(MAIN_RNG)
    Set oldUsedRng = oldWs.UsedRange.Cells
    Set newWs = Sheets.Add(After:=oldWs)
    oldUsedRng.Copy
    With newWs.Cells
        .PasteSpecial xlPasteColumnWidths
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormulasAndNumberFormats
        .Cells(1, 1).Copy
        .Cells(1, 1).Select
    End With
    arr = GetCommentArrayFromSheet(oldWs)
    RemoveSheet oldWs
    CreateAndFormatComments newWs, arr
    newWs.Name = wsName
UpdateDisplay True
    InputBox "Duration: ", "Duration", Timer - t
    '272.4296875 (4.5 min), 269.6796875, Excel 2007: 406.83203125 (6.8 min)
End Sub

---

.

Other functions:

---

Public Sub UpdateDisplay(ByVal state As Boolean)
    With Application
        .Visible = state
        .ScreenUpdating = state
        '.VBE.MainWindow.Visible = state
    End With
End Sub

Public Sub RemoveSheet(ByRef ws As Worksheet)
    With Application
        .DisplayAlerts = False
        ws.Delete
        .DisplayAlerts = True
    End With
End Sub

'---------------------------------------------------------------------------------------

Public Sub MakeComments(ByRef rng As Range)
    Dim t As Double, i As Long, cel As Range, txt As String
    txt = MAIN_CMT & Chr(10)
    For i = 1 To 5
        txt = txt & txt
    Next
    For Each cel In rng
        With cel
            If .Comment Is Nothing Then .AddComment txt
        End With
    Next
End Sub

Public Sub RemoveComments(ByRef ws As Worksheet)
    Dim cmt As Comment
    'For Each cmt In ws.Comments
    '    cmt.Delete
    'Next
    ws.UsedRange.ClearComments
End Sub

'---------------------------------------------------------------------------------------

Public Function GetCommentArrayFromSheet(ByRef ws As Worksheet) As String()
    Dim arr() As String, max As Long, i As Long, cmt As Comment
    If Not ws Is Nothing Then
        max = ws.Comments.Count
        If max > 0 Then
            ReDim arr(1 To max, 1 To 2)
            i = 1
            For Each cmt In ws.Comments
                With cmt
                    arr(i, 1) = .Parent.Address
                    arr(i, 2) = .Text
                End With
                i = i + 1
            Next
        End If
    End If
    GetCommentArrayFromSheet = arr
End Function

Public Sub CreateAndFormatComments(ByRef ws As Worksheet, ByRef commentArr() As String)
    Dim i As Long, max As Long
    max = UBound(commentArr)
    If max > 0 Then
        On Error GoTo restoreDisplay
        For i = 1 To max
            With ws.Range(commentArr(i, 1))
                .AddComment commentArr(i, 2)
                With .Comment.Shape.TextFrame
                    With .Characters.Font
                        If .Bold Then .Bold = False                     'True
                        If .Name <> "Calibri" Then .Name = "Calibri"    '"Arial"
                        If .Size <> 9 Then .Size = 9                    '8
                        If .ColorIndex <> 9 Then .ColorIndex = 9
                    End With
                    If Not .AutoSize Then .AutoSize = True
                End With
                DoEvents
            End With
        Next
    End If
    Exit Sub
restoreDisplay:
    UpdateDisplay True
    Exit Sub
End Sub

---

Hope this helps

回答4:

I think I found 2 ways to improve performance for your task

---

1. The code in your example runs for an average of 25 minutes, I got it down to 4.5 minutes:

   • Create a new sheet
   • Copy & paste all values from the initial sheet
   • Copy all comments to a 2 dimensional array (cell address & comment text)
   • Generates the same comments for the same cells on the new sheet, with the new format

---

2. This one is quite simple to implement and test, and is very specific to your case

   • From the description, you are processing the same comments over and over
   • The most expensive part is changing the font
   • With this adjustment it will only update the font for the new comments (existing ones are already using the font from previous processing, even if the text gets updated)

Try updating this part of the code in the actual file (it's not as effective for the example)

---

With .Shape.TextFrame
    With .Characters.Font
        If Not .Bold Then .Bold = True
        If .Name <> "Arial" Then .Name = "Arial"
        If .Size <> 8 Then .Size = 8
    End With
    If Not .AutoSize Then .AutoSize = True
End With

or:

With .Shape.TextFrame
    With .Characters.Font
        If Not .Bold Then
            .Bold = True
            .Name = "Arial"
            .Size = 8
        End If
    End With
    If Not .AutoSize Then .AutoSize = True
End With

---

Let me know if you're interested in the other option and I can provide the implementation

回答5:

Turn off screen updating and if you not need to workboook to recalculate during the macro, setting the calculation to manual will really shave off some time. This will prevent every formula in your workbook for processing every time you alter a cell. These two functions allow me to crunch out rather large reports in a matter of seconds.

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 

Of course, at the end of the macro, set them back to true and automatic

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

来源：https://stackoverflow.com/questions/31234053/speed-up-working-with-comments-in-excel-vba