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

我有一个子程序，在循环中进行大约 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 很陌生，所以请告诉我我是否在这里很愚蠢。

感谢您的关注 安东尼

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

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