vba - 如何使大循环的联合范围更快

Question

我有一个 sub 在循环中进行了大约 5000 次迭代后变得非常慢。
否则很快。

Windows 8.1 专业版 64 位

Excel 2013 (15.0.4701.1001) MSO (15.0.4701.1000) 64 位

Sub UnionSlow()

Dim ColArray() As Variant
Dim NumLastRow, NumRow, Cnt As Long
Dim CurCell As String
Dim rngPRC As Range

'Set an arbitrary row so range is not empty

Set rngPRC = Rows(1)

'Get the total number of rows in the sheet 

TotalRows = Rows(Rows.Count).End(xlUp).Row

'Load the first column into an array (v quick)

ColArray = Range(Cells(1, 1), Cells(TotalRows, 1)).Value

'Now loop through the array and add ROWS to the RANGE depending on a condition

For NumRow = 1 To TotalRows

       CurCell = ColArray(NumRow, 1)

       If CurCell = "PRC" Then Set rngPRC = Union(rngPRC, Rows(NumRow))

Next NumRow

'Display a few things

MsgBox "Areas count " & rngPRC.Areas.Count
MsgBox "Address " & rngPRC.Address
MsgBox "Length array " & UBound(ColArray) & " items"

rngPRC.EntireRow.Font.Color = RGB(0, 0, 128)

End Sub

所以问题是这会非常快速地加载数组并非常快速地更改颜色。
减慢它的速度是建立行的范围。
多达 2000 行，速度很快(不到 1 秒)
最多 5000 行，速度较慢(大约 5 秒)
大约 20000 行大约需要 10 分钟

我对 VBA 很陌生，所以请告诉我我是否在这里很愚蠢。

谢谢你看
安东尼

Answer 1

我同意其中一条评论指出自动过滤器在这种情况下会很好地工作。这是一个草案解决方案:

AutoFilterMode = False
TotalRows = Rows(Rows.Count).End(xlUp).Row
Set rngPRC = Range(Cells(1, 1), Cells(TotalRows, 1))

rngPRC.AutoFilter field:=1, Criteria1:="PRC"

If rngPRC.SpecialCells(xlCellTypeVisible).Count > 1 Then 'check if rows exist

  Set rngPRC = rngPRC.Resize(rngPRC.Rows.Count - 1, 1).Offset(1, 0) _
         .SpecialCells(xlCellTypeVisible).EntireRow

  'perform your operations here:  
  rngPRC.Font.Color = RGB(0, 0, 128)
End If

AutoFilterMode = False