在Excel VBA中加快处理注释
这是我devise的一个例子，我创build这个来解释我遇到的问题。 基本上我想要这个代码比它运行得更快。 在新的工作表中，每个单元格的循环都会快速启动，但是如果让它运行到接近完成状态，然后再次运行，则每个单元格将会达到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 更新2015年12月11日，我想这个指出的地方，以防万一有人遇到它，我试图优化这么多的原因是因为VSTO不会让我添加所有这些评论的工作簿文件。 在与微软合作6个月之后，这已经成为VSTO和Excel中的一个确认错误。
https://connect.microsoft.com/VisualStudio/feedback/details/1610713/vsto-hangs-while-editing-an-excel-macro-enabled-workbook-xlsm-file
根据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
同样根据Range.SpecialCells方法的官方文档，您可以使用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
我仍然不清楚填充所有未评论的单元格的背后是否有空白的评论，但是如果您只想在工作表上使用评论，最好使用评注单元格的子集而不是循环遍历所有单元格寻找评论。
通过closures屏幕更新，我可以将每次迭代的时间从100ms减less到17ms左右。 您可以将以下内容添加到过程的开始处：
Application.ScreenUpdating = False
您可以在过程结束时重新启用更新，方法是将其重新设置为true。
此代码将数据复制到新的工作表，并重新创build所有注释：
在新的用户模块中：
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
。
其他function：
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
希望这可以帮助
我想我find了两种方法来提高你的任务的性能
-
在你的例子中的代码平均运行25分钟，我把它下降到4.5分钟：
- 创build一个新工作表
- 复制并粘贴来自初始工作表的所有值
- 将所有注释复制到2维数组（单元格地址和注释文本）
- 使用新格式为新工作表上的相同单元格生成相同的注释
-
这个实现和testing非常简单，对你的情况非常具体
- 从描述中，您一次又一次地处理相同的评论
- 最昂贵的部分是改变字体
- 通过这种调整，它只会更新新注释的字体（现有的字体已经在使用之前处理的字体，即使文本被更新）
尝试更新实际文件中的这部分代码（这不是有效的例子）
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
如果您对另一个选项感兴趣，请告诉我，我可以提供实施
closures屏幕更新，如果你不需要工作簿在macros中重新计算，将计算设置为手动将真正减less一些时间。 这将防止您的工作簿中的每个公式每次更改单元格时进行处理。 这两个function使我可以在几秒钟内就可以剔除相当大的报告。
Application.ScreenUpdating = False Application.Calculation = xlCalculationManual
当然，在macros的末尾，将它们设置为true和自动
Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic