VBA быстрый способ нарисовать тысячи ячеек из массива адресов

Question

У меня есть лист с ~ 300 строками и 30 столбцами чисел. Мне нужно покрасить ячейки в результате обработки события SelectionChange. Производительность важна как вопрос юзабилити.

Первый способ - взять Range объект для каждой ячейки, которую я собираюсь выделить:

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

Этот путь довольно медленный даже при отключенном ScreenUpdating.

Второй способ - создать строку с набором адресов:

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)

Этот способ выдает ошибку, когда выделено 42 или более ячеек.

Третий способ - создать диапазон как объединение двух диапазонов, которые являются ранее накопленными ячейками и текущей ячейкой:

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)

Этот способ довольно быстрый, но после 1000 ячеек время его выполнения увеличивается в геометрической прогрессии: 1000 ячеек выделяются за 1,5 с, 2000 ячеек выделяются за 8 с.

Какой самый быстрый способ указать и выделить произвольные 1000..10000 ячеек?

Answer 1

Это то, что вы хотите сделать. Без дополнительной информации о том, какой пункт вы бы использовали, мне пришлось бы придумать собственную загадку: я использую многие (все?) Методы, используемые для ускорения программ. 10 выполнений имели среднее время выполнения 0,2254 секунды с 10k окрашенных ячеек

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