how to make union range faster for large loops

问题

I have a sub that becomes very slow after about 5000 iterations in a loop. It's quick otherwise.

Windows 8.1 Pro 64 bit

Excel 2013 (15.0.4701.1001) MSO (15.0.4701.1000) 64-bit

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

So the thing is that this loads the array very quickly and changes the color very quickly. What slows it down is building the range of rows. Up to 2000 rows it's quick (less than 1 second) Up to 5000 rows it's slower (about 5 seconds) At about 20000 rows it takes about 10 minutes

I'm very new to VBA so please tell me if I'm being daft here.

thanks for looking Antony

回答1:

I agree with one of the comments stating that autofilter would work well in this situation. Here is a draft solution:

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

回答2:

Instead of building your range one row at a time:

If your range is contiguous from top to bottom:
1. loop from the top to bottom
2. create one range
3. set the color
If your range is non-contiguous:
1. start at the top
2. loop through to find the break point
3. union that to your range
4. loop to find find the next range start point
5. return to step 2
6. lather, rinse, repeat until there are no more 'start points'
7. set the color of your built range

This will at least minimize the number of unions you have to do.

回答3:

I wouldn't use loop at all - use FIND instead.

If you copy the FindAll code from Chip Pearsons site: http://www.cpearson.com/excel/findall.aspx

You can then use this short procedure to do what you're after (copied from Chips site with a couple of changes to make it work for you:

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

It should be fairly easy to update the FindAll function to work faster by removing code not relevant to your needs.

来源：https://stackoverflow.com/questions/29230757/how-to-make-union-range-faster-for-large-loops

标签

excel

vba

excel-vba

range

union