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.
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
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.
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.
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
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
I think I found 2 ways to improve performance for your task
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
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
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
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