Альтернативный более быстрый метод для окрашивания клеток - PullRequest
Новая
       6

Альтернативный более быстрый метод для окрашивания клеток

1 голос
/ 05 февраля 2020

Эта часть моего макроса предназначена для окрашивания ячеек в строке B, в зависимости от их значения и значения соответствующей ячейки в строке Q. Это работает хорошо, но когда файл большой (иногда более 500 000 строк), это Шаг действительно может замедлить все выполнение макроса. Существует также вероятность того, что мне нужно будет добавить больше цветов в будущем, что будет означать больше строк IF, что замедлит его еще больше. 

Dim LastRow As Long
LastRow = Cells(Rows.Count, 2).End(xlUp).Row 
Dim i As Long, r1 As Range, r2 As Range
For i = 11 To LastRow
  Set r1 = Range("B" & i)
  Set r2 = Range("Q" & i)
If r2 = "001111" Then r1.Interior.Color = vbGreen
If (r1 < 4 Or r1 > 0) And (r2 <> "001111") Then r1.Interior.Color = vbYellow
If (r1 > 3 Or r1 < 1) And (r2 <> "001111") Then r1.Interior.Color = vbRed
Next i

Я попытался использовать некоторый код для условного форматирования на весь ряд. Это намного быстрее, но я не смог понять, как включить значение ячейки в столбце Q в качестве условия. Я также был ограничен не более чем тремя условиями. Есть ли способ выполнить sh эту задачу так, чтобы она была быстрее, чем мой текущий код, что также позволит использовать больше условий / цветов в будущем?

Ответы [ 2 ]

3 голосов
/ 05 февраля 2020

Поцарапайте мою предыдущую попытку. Я согласен, что Range.AutoFilter может быть даже лучше: 

Sub Test()

Dim lr As Long, rng As Range

With Sheet1

    'Get last used row of data and set range
    lr = .Cells(.Rows.Count, 2).End(xlUp).Row
    Set rng = .Range("B10:Q" & lr)

    'Apply first filter and color Green
    rng.AutoFilter 16, "001111"
    If rng.Columns(1).SpecialCells(12).Count > 1 Then rng.Columns(1).Offset(1).Resize(lr - 10).Interior.Color = vbGreen

    'Apply second filter and color Yellow
    rng.AutoFilter 16, "<>*001111*"
    rng.AutoFilter 1, "<4", xlAnd, ">0"
    If rng.Columns(1).SpecialCells(12).Count > 1 Then rng.Columns(1).Offset(1).Resize(lr - 10).Interior.Color = vbYellow

    'Apply third filter and color Red
    rng.AutoFilter 1, ">3", xlOr, "<1"
    If rng.Columns(1).SpecialCells(12).Count > 1 Then rng.Columns(1).Offset(1).Resize(lr - 10).Interior.Color = vbRed

    'Remove AutoFilter
    rng.AutoFilter

End With

End Sub
0 голосов
/ 05 февраля 2020

Полагаю, быстрее всего будет использовать массив? Может быть какой-то фильтр, но я сейчас собираюсь сделать массив: 

Application.ScreenUpdating = False

ThisWorkbook.Sheets("Tabelle1").Range("B11:B500000") = 1
ThisWorkbook.Sheets("Tabelle1").Range("Q11:Q500000") = 2
LastRow = Cells(Rows.Count, 2).End(xlUp).Row

Dim r1
Dim r2

r1 = ThisWorkbook.Sheets("Tabelle1").Range("B11:B" & LastRow)
r2 = ThisWorkbook.Sheets("Tabelle1").Range("Q11:Q" & LastRow)

For i = LBound(r1) To UBound(r1)
    If r2(i, 1) = "001111" Then r1(i, 1) = vbGreen
    If (r1(i, 1) < 4 Or r1(i, 1) > 0) And (r2(i, 1) <> "001111") Then r1(i, 1) = vbYellow
    If (r1(i, 1) > 3 Or r1(i, 1) < 1) And (r2(i, 1) <> "001111") Then r1(i, 1) = vbRed
Next i

With ThisWorkbook.Sheets("Tabelle1")
    For i = LBound(r1) To UBound(r1)
        .Range("B" & 10 + i).Interior.Color = r1(i, 1)
    Next
End With

Application.ScreenUpdating = True

Я бы sh мы могли бы применить .Interior.Color все в одном go, но я не могу этого получить работать. Если кто-то еще, я бы тоже хотел знать! Это выполняется в 24,75 с на моей машине. О, и я не проверял вашу логику c для вещей <,>, я просто добавил массив. Скорее всего, он сломается, если в одну из ячеек будет записано что-то неожиданное, например строка или что-то еще Также я предполагаю, что вы используете IFs вместо elseif по причине? Не то чтобы это действительно имело значение, если сделано в массиве, просто любопытно.

...