加快处理 Excel VBA 中的注释

Question

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

有没有办法加快这个过程？

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 不允许我添加工作簿文件所有这些评论。在与 Microsoft 合作 6 个月后，这现在是 VSTO 和 Excel 中已确认的错误。

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

Answer 1

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

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 you can easily determine a subset of cells in a worksheet using the xlCellTypeComments 常量作为 Type 参数。

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

我仍然不清楚用空白注释填充所有未注释的单元格背后的原因，但如果您只想在工作表上使用注释，最好使用注释单元格的子集而不是而不是循环遍历所有单元格寻找评论。

Answer 2

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

Application.ScreenUpdating = False

您可以在过程结束时将其设置回 true 以重新打开更新。

Answer 3

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

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

当然，在宏的最后，将它们设置回true和automatic

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Answer 4

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

您示例中的代码平均运行 25 分钟，我将其缩短为 4.5 分钟：
- 新建一个sheet
- 复制并粘贴初始 sheet
- 将所有评论复制到二维数组（单元格地址和评论文本）
- 使用新格式

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

尝试更新实际文件中的这部分代码（对于示例来说效果不佳）

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

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

Answer 5

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

在新用户模块中：

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 VBA 中的注释

Speed Up Working With Comments in Excel VBA

excel

vba

vsto

excel-2010