加快在 Excel VBA 中处理注释的速度答案

【问题标题】：Speed Up Working With Comments in Excel VBA加快在 Excel VBA 中处理注释的速度
【发布时间】：2015-07-05 19:13:44
【问题描述】：

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

有没有办法让这个过程更快？

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

2015 年 12 月 11 日更新，我希望在某处注明这一点，以防万一有人遇到它，我试图优化它的原因是因为 VSTO 不允许我添加包含所有这些 cmets 的工作簿文件。在与 Microsoft 合作 6 个月后，这现在是 VSTO 和 Excel 中已确认的错误。

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

【问题讨论】：

为什么要向当前不包含评论的单元格添加空白评论？难怪后续运行将有更多操作来完成 id 您将 cmets 添加到不包含一个的所有内容。
当你重新运行你的宏时，任何新的单元格是否会被注释或删除它们的 cmets？

标签： vba excel excel-2010 vsto

【解决方案1】：

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

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

此外，根据Range.SpecialCells method 的官方文档，您可以使用xlCellTypeComments 常量作为类型参数轻松确定工作表中的单元格子集。

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

我仍然不清楚用空白注释填充所有非注释单元格的原因，但如果您尝试仅在工作表上使用 cmets，最好使用注释单元格的子集而不是循环通过所有单元格寻找评论。

【讨论】：

这看起来很有趣。我只填写了空白单元格以在我修改 cmets 的方法中演示我的工作表。这样任何人都可以帮助我解决问题。我可以在这个方法中获取特殊的评论单元格属性吗？
在使用此解决方案一段时间后，它是一种更快地遍历 cmets 的方法，但是它不能解决在不存在时将注释添加到单元格的问题。这仅在单元格已经包含 cmets 时才有效。

【解决方案2】：

通过关闭屏幕更新，我能够将每次迭代的时间从大约 100 毫秒减少到大约 17 毫秒。您可以在程序的开头添加以下内容：

Application.ScreenUpdating = False

您可以在过程结束时将更新重新设置为 true。

【讨论】：

是的，这是真的，我没有提到我目前使用它以及禁用计算。 17ms 仍然是一个很长的时间来改变一个评论。在我禁用屏幕更新的工作表上，我们每个单元格注册 300 毫秒。我真的希望有一种方法可以将所有 cmets 放入字典并在内存中对其进行操作，然后将它们粘贴回一个糊状物中。而不是为每个单元格调用工作表

【解决方案3】：

此代码将数据复制到新工作表，并重新创建所有注释：

在新的用户模块中：

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

希望对你有帮助

【讨论】：

这在 Excel 2010 中有效，但在 Excel 2007 中用完 1.7 Gb 后内存不足，并且 On Error 无法解决问题。您是否愿意接受一种完全绕过评论但模拟相同功能的全新方法（意味着使用隐藏工作表和 OnClick 事件来显示每个单元格的相关数据）
悬停数据确实是我所追求的，所以如果它没有在悬停时弹出该弹出窗口，那么就不会。不过谢谢。
好的，我也让它在 Excel 2007 中工作，并用最新的变化更新了答案；让我知道它是否会提高性能

【解决方案4】：

我想我找到了 2 种方法来提高你的任务性能

您示例中的代码平均运行 25 分钟，我将其缩短到 4.5 分钟：
- 创建新工作表
- 复制并粘贴初始工作表中的所有值
- 将所有 cmets 复制到二维数组（单元格地址和注释文本）
- 使用新格式为新工作表上的相同单元格生成相同的 cmets

这个实现和测试非常简单，并且非常适合您的情况
- 根据描述，您正在一遍又一遍地处理相同的 cmets
- 最昂贵的部分是更改字体
- 通过此调整，它只会更新新 cmets 的字体（现有 cmets 已在使用之前处理的字体，即使文本已更新）

尝试在实际文件中更新这部分代码（对例子来说没有那么有效）

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

如果您对其他选项感兴趣，请告诉我，我可以提供实施

【讨论】：

我对另一个选项感兴趣。当我尝试将 cmets 放入一个数组时，我发现这些字段无法容纳那么多文本，并且正在修剪它。也许我做错了。
我需要把它放在一个新的答案中，因为代码有点长

【解决方案5】：

关闭屏幕更新，如果您不需要在宏期间重新计算工作簿，将计算设置为手动将真正节省一些时间。这将阻止您每次更改单元格时处理工作簿中的每个公式。这两个功能让我可以在几秒钟内处理出相当大的报告。

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

当然，在宏结束时，将它们设置回true和自动

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

【讨论】：