加快在Excel VBA中使用注释的速度

这是我设计的一个例子，我创建这个来解释我遇到的问题。基本上，我希望这段代码比它运行得更快。在新的工作表上，每个单元的循环都会快速启动，但如果让它运行到接近完成，然后再次运行，则每个单元的循环将达到100ms。在我的工作表中，我有16000个单元格，其中有很多这样的注释，每次代码运行时都会对它们进行单独操作。在本例中，它们显然都是相同的，但在实际应用中，每一个都是不同的

有没有办法加快这个过程

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

更新12-11-2015，我希望在某个地方注意到这一点，以防有人碰到它，我之所以尝试对其进行如此多的优化，是因为VSTO不允许我添加包含所有这些注释的工作簿文件。在与Microsoft合作6个月后，这已成为VSTO和Excel中的一个确认错误

根据MSDN和文档，您可以通过其索引位置引用工作表中的所有注释，并直接处理它们，而不是循环遍历每个单元格并确定其中是否包含注释

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

Dim c尽可能长
通过关闭屏幕更新，我可以将每次迭代的时间从100ms左右减少到17ms左右。您可以将以下内容添加到过程的开头：

Application.ScreenUpdating = False

您可以在过程结束时通过将其设置回true来重新启用更新功能。
关闭屏幕更新功能，如果您不需要workboook在宏过程中重新计算，将计算设置为manual将真正节省一些时间。这将防止每次更改单元格时处理工作簿中的每个公式。这两个函数允许我在几秒钟内处理出相当大的报告

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 

当然，在宏的末尾，将它们设置回true和automatic

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

我想我找到了两种方法来提高你任务的绩效


您示例中的代码平均运行25分钟，我将其缩短为4.5分钟：


创建新图纸
复制并粘贴初始工作表中的所有值
将所有注释复制到二维数组（单元格地址和注释文本）
使用新格式为新工作表上的相同单元格生成相同的注释


这是一个非常简单的实现和测试，是非常具体的您的情况


从描述中，您一遍又一遍地处理相同的注释
最昂贵的部分是改变字体
通过此调整，它将只更新新注释的字体（现有注释已使用先前处理的字体，即使文本得到更新）

尝试在实际文件中更新这部分代码（对于本例来说效果不太好）



如果您对其他选项感兴趣，请告诉我，我可以提供实现
此代码将数据复制到新工作表，并重新创建所有注释：

在新用户模块中：




其他职能：


Public子UpdateDisplay（ByVal状态为布尔值）
应用
.可见=状态
.Screen更新=状态
'.VBE.MainWindow.Visible=状态
以
端接头
公共子移除表（ByRef ws As工作表）
应用
.DisplayAlerts=False
ws.Delete
.DisplayAlerts=True
以
端接头
'---------------------------------------------------------------------------------------
公共子MakeComments（ByRef rng作为范围）
Dim t为双精度，i为长，cel为范围，txt为字符串
txt=主要的CMT和Chr（10）
对于i=1到5
txt=txt&txt
下一个
对于rng中的每个cel
和cel
如果.Comment为空，则.AddComment txt
以
下一个
端接头
公用子删除项（ByRef ws As工作表）
Dim cmt作为评论
'对于ws.Comments中的每个cmt
'cmt.删除
”“接着呢
ws.UsedRange.ClearComments
端接头
'---------------------------------------------------------------------------------------
公共函数GetCommentArrayFromSheet（ByRef ws作为工作表）作为字符串（）
Dim arr（）作为字符串，max作为长度，i作为长度，cmt作为注释
如果不是的话，那么ws什么都不是
max=ws.Comments.Count
如果最大值>0，则
ReDim arr（1到最大值，1到2）
i=1
对于ws.Comments中的每个cmt
使用cmt
arr（i，1）=.Parent.Address
arr（i，2）=.文本
以
i=i+1
下一个
如果结束
如果结束
GetCommentArrayFromSheet=arr
端函数
Public Sub CreateAndFormatComments（ByRef ws作为工作表，ByRef commentArr（）作为字符串）
我和他一样长，马克斯和他一样长
最大值=UBound（注释arr）
如果最大值>0，则
转到restoreDisplay时出错
对于i=1至最大值
具有ws.Range（commentArr（i，1））
.AddComment commentArr（i，2）
With.Comment.Shape.TextFrame
With.Characters.Font
If.Bold Then.Bold=False“True”
如果.Name“Calibri”，则.Name=“Calibri”'“Arial”
如果.Size为9，则.Size=9'8
如果.ColorIndex为9，则.ColorIndex=9
以
如果不是，则为.AutoSize，然后为.AutoSize=True
以
多芬特
以
下一个
如果结束
出口接头
恢复显示：
UpdateDisplay True
出口接头
端接头


希望这有帮助
为什么要在当前不包含注释的单元格中添加空白注释？这是一个很小的奇迹，后续的运行将有更多的操作来完成，你添加注释到所有不包含注释的地方
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

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

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

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

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