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

我有一个在循环中大约5000次迭代之后变得非常慢的子。 否则很快。

Windows 8.1 Pro 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 

所以事情是，这很快加载数组，并迅速改变颜色。 什么减慢是build立行的范围。 高达2000行快（less于1秒）高达5000行慢（约5秒）在大约20000行大约需要10分钟

我对VBA很新，所以请告诉我，如果我在这里呆了一会儿。

谢谢你看安东尼

Answer 1

我同意其中一个意见，表示自动filter在这种情况下会很好的工作。 这是一个解决scheme草案：

 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 

Answer 2

而不是一次一个地build立你的范围：

• 如果你的范围从上到下是连续的：

  1. 从上到下循环
  2. 创build一个范围
  3. 设置颜色

• 如果你的范围是非连续的：

  1. 从顶部开始
  2. 循环find中断点
  3. 联合你的范围
  4. 循环find下一个范围起点
  5. 返回到第2步
  6. 泡沫，冲洗，重复，直到没有更多的“起点”
  7. 设置你build造的范围的颜色

这至less可以减less你需要做的工会数量。

Answer 3

我不会使用循环 – 使用FIND来代替。

如果您从Chip Pearsons站点复制FindAll代码： http ://www.cpearson.com/excel/findall.aspx

然后，您可以使用这个简短的程序来完成您的工作（从Chips站点复制一些更改以使其适用于您：

 Sub TestFindAll() Dim SearchRange As Range Dim FindWhat As Variant Dim FoundCells As Range Set SearchRange = Sheet1.Columns(1) FindWhat = "PRC" Set FoundCells = FindAll(SearchRange:=SearchRange, _ FindWhat:=FindWhat, _ LookIn:=xlValues, _ LookAt:=xlWhole, _ SearchOrder:=xlByColumns, _ MatchCase:=False, _ BeginsWith:=vbNullString, _ EndsWith:=vbNullString, _ BeginEndCompare:=vbTextCompare) If FoundCells Is Nothing Then MsgBox "Value Not Found", vbOKOnly Else FoundCells.EntireRow.Font.Color = RGB(0, 0, 128) End If End Sub 

通过删除与您的需求无关的代码，更新FindAll函数以更快地工作应该相当容易。