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

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

而不是一次一行地构建范围：

如果您的范围从上到下是连续的：
1. 从上到下循环
2. 创建一个范围
3. 设置颜色
如果您的范围不连续：
1. 从顶部开始
2. 循环寻找断点
3. 将其合并到您的范围
4. 循环寻找下一个范围起点
5. return 到第 2 步
6. 起泡、冲洗、重复，直到没有更多 'start points'
7. 设置您构建的范围的颜色

这至少会减少您必须执行的并集数。

Answer 2

我根本不会使用循环 - 而是使用 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 函数以更快地工作应该相当容易。

Answer 3

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

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

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

how to make union range faster for large loops

vba

excel

range

union