Speed Up Working With Comments in Excel VBA - vba

Question

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.
https://connect.microsoft.com/VisualStudio/feedback/details/1610713/vsto-hangs-while-editing-an-excel-macro-enabled-workbook-xlsm-file

Answer 1

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
Also according to official docs for the Range.SpecialCells method you can easily determine a subset of cells in a worksheet using the xlCellTypeComments constant as the Type parameter.
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.

Answer 2

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.

Answer 3

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
.
Other functions:
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

Answer 4

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
or:
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

Answer 5

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