Question

我有一个sub在循环中大约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

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

我对VBA很新，所以请告诉我，如果我在这里愚蠢。

谢谢你的期待安东尼

Answer 1

不是一次建立一行范围：

如果您的范围从上到下是连续的：
1. 从上到下循环
2. 创建一个范围
3. 设置颜色
如果您的范围不连续：
1. 从顶部开始
2. 循环查找断点
3. 联合您的范围
4. 循环找到下一个范围起点
5. 返回第2步
6. 泡沫，冲洗，重复，直到没有更多的起点＆＃39;
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

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

3 个答案: