VBA quick way to paint thousands of cells from array of addresses - vba

Question

I have a sheet with ~300 lines and 30 columns of numbers. I need to paint cells as a result of processing SelectionChange event. Performance is imporant as issue of usability.
First way is to take a Range object for every cell I'm going to highlight:
For x = 1 To 30: For y = 1 To lastNonemptyRow
If someClause(CInt(Cells(rowIdx, colIdx).Value)) Then
Range(Cells(rowIdx, colIdx).Value).Interior.Color = Rgb(255, 0, 0)
End If
Next y: Next x
This way is quite slow even with disabled ScreenUpdating.
Second way is to make a string with set of addresses:
addressesToHighlight = ""
For x = 1 To 30: For y = 1 To lastNonemptyRow
If someClause(CInt(Cells(rowIdx, colIdx).Value)) Then
addressesToHighlight = addressesToHighlight & Cells(rowIdx, colIdx).Address & ", "
End If
Next y: Next x
Range(addressesToHighlight).Interior.Color = Rgb(255, 0, 0)
This way gives error when there is 42 or more cells to highlight.
Third way is to create a range as union of two ranges which are previously accumulated cells and current cell:
Set resultRange = Nothing
For x = 1 To 30: For y = 1 To lastNonemptyRow
If someClause(CInt(Cells(rowIdx, colIdx).Value)) Then
If resultRange is Nothing then
Set resultRange = Range(Cells(rowIdx, colIdx))
Else
Set resultRange = Union(resultRange, Range(Cells(rowIdx, colIdx)))
End if
End If
Next y: Next x
resultRange.Interior.Color = RGB(255, 0, 0)
This way is quite fast but after 1000 cells its execution time grows exponentially: 1000 cells are highlighted in 1.5 sec, 2000 cells are highlighted in 8 sec.
What is the fastest way to specify and highlight arbitrary 1000..10000 cells?

Answer 1

This is sort of what you are looking to do. Without further information re what sort of clause you would use I had to come up with own puzzle I employee many (all?) of the techniques used to speed up programs. 10 executes had average runtime of .2254 seconds with 10k cells painted
Option Explicit
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Sub newnew()
Dim started As Long
Dim ws As Worksheet
Dim paintRng As String
Dim rng As Range
Dim ColumnCount As Long
Dim RowCount As Long
Dim arrRng() As Variant
Dim wsTwo As Worksheet
Dim rngTwo As Range
Dim colNum As Long
Dim rowNum As Long
Dim ended As Long
started = timeGetTime
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayStatusBar = False
.EnableEvents = False
End With
started = timeGetTime
Set ws = Sheets("Sheet1")
ws.DisplayPageBreaks = False
paintRng = "A1:J1000"
Set rng = ws.Range(paintRng)
ColumnCount = rng.Columns.Count
RowCount = rng.Rows.Count
ReDim arrRng(1 To RowCount, 1 To ColumnCount)
arrRng = rng
Debug.Print ColumnCount
Debug.Print RowCount
Set ws = Nothing
Set rng = Nothing
Set wsTwo = Sheets("Sheet2")
wsTwo.DisplayPageBreaks = False
Set rngTwo = wsTwo.Range(paintRng)
With rngTwo
For colNum = 1 To ColumnCount
For rowNum = 1 To RowCount
If arrRng(rowNum, colNum) = 1 Then
.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
ElseIf arrRng(rowNum, colNum) = 2 Then
.Cells(rowNum, colNum).Interior.Color = RGB(125, 0, 0)
ElseIf arrRng(rowNum, colNum) = 3 Then
.Cells(rowNum, colNum).Interior.Color = RGB(0, 255, 0)
ElseIf arrRng(rowNum, colNum) = 4 Then
.Cells(rowNum, colNum).Interior.Color = RGB(0, 0, 255)
ElseIf arrRng(rowNum, colNum) = 5 Then
.Cells(rowNum, colNum).Interior.Color = RGB(125, 125, 0)
ElseIf arrRng(rowNum, colNum) = 6 Then
.Cells(rowNum, colNum).Interior.Color = RGB(125, 0, 125)
ElseIf arrRng(rowNum, colNum) = 7 Then
.Cells(rowNum, colNum).Interior.Color = RGB(75, 75, 200)
ElseIf arrRng(rowNum, colNum) = 8 Then
.Cells(rowNum, colNum).Interior.Color = RGB(50, 125, 255)
End If
Next rowNum
Next colNum
End With
Set wsTwo = Nothing
Set rngTwo = Nothing
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayStatusBar = True
.EnableEvents = True
End With
ended = timeGetTime
Debug.Print ColumnCount * RowCount & " Cells Painted In " & (ended - started) / 1000 & " seconds"
End Sub