在过滤范围内找到最大范围的可见单元格

Question

I would like to be able to find the largest visible area of continuous rows in a filtered table. I know one possible way would be to loop through visible cells using the "xlCellTypeVisible" property and count cells in each visible area. However, the data is consisted of tens and sometimes hundreds of thousands of rows so I was wondering if there is a faster, more efficient way to do this.

Answer 1

Some months ago I had a vaguely similar requirement and was unhappy with the best solution I had discovered. Staring at your question, I suddenly thought of two new techniques. The macro below demonstrates both. Both give acceptable results although I cannot imagine a situation in which technique 2 is not the faster.

My macro starts:

Option Explicit
Sub LargestVisibleRange()

  Dim Count As Long
  Dim NumRowsInLargestRange As Long
  Dim RngCrnt As Range
  Dim RngTgt As Range
  Dim RowCrnt As Long
  Dim RowCrntRangeStart As Long
  Dim RowLargestRangeEnd As Long
  Dim RowLargestRangeStart As Long
  Dim RowMax As Long
  Dim RowPrev As Long
  Dim StartTime As Single

  With Worksheets("TrainData")

    RowMax = .Cells(Rows.Count, "A").End(xlUp).Row
    Debug.Print "1  RowMax " & RowMax

    .Cells.AutoFilter
    .Range(.Cells(2, 1), .Cells(RowMax, "Z")).AutoFilter Field:=2, Criteria1:=ChrW$(&H2116) & " 9/10"

I have some data I use when I am experimenting with filters. If you wish to use this macro as a basis for your own experiments, you will have to replace the above statements.

The macro continues:

Set RngTgt = .Range(.Rows(2), .Rows(RowMax)).SpecialCells(xlCellTypeVisible)
Debug.Print "2  RngTgt " & RngTgt.Address
Count = 1
Debug.Print "3  ";
For Each RngCrnt In RngTgt
  Debug.Print RngCrnt.Address & " ";
  Count = Count + 1
  If Count = 30 Then Exit For
Next
Debug.Print

Set RngTgt = RngTgt.EntireRow
Debug.Print "4  RngTgt " & RngTgt.Address

Count = 1
Debug.Print "5  ";
For Each RngCrnt In RngTgt
  Debug.Print RngCrnt.Address & " ";
  Count = Count + 1
  If Count = 30 Then Exit For
Next
Debug.Print

The output from the statement above is:

1  RowMax 5691
2  RngTgt $2:$4,$20:$22,$38:$40,$56:$58,$74:$76,$92:$94,$110:$112,$128:$130,$146:$148,$164:$166,$182:$184,$200:$202,$218:$220,$236:$238,$254:$256,$272:$274,$290:$292,$308:$310,$326:$328,$344:$346,$362:$364,$380:$382,$398:$400,$416:$418,$434:$436,$452:$454,$470:$472
3  $A$2 $B$2 $C$2 $D$2 $E$2 $F$2 $G$2 $H$2 $I$2 $J$2 $K$2 $L$2 $M$2 $N$2 $O$2 $P$2 $Q$2 $R$2 $S$2 $T$2 $U$2 $V$2 $W$2 $X$2 $Y$2 $Z$2 $AA$2 $AB$2 $AC$2 
4  RngTgt $2:$4,$20:$22,$38:$40,$56:$58,$74:$76,$92:$94,$110:$112,$128:$130,$146:$148,$164:$166,$182:$184,$200:$202,$218:$220,$236:$238,$254:$256,$272:$274,$290:$292,$308:$310,$326:$328,$344:$346,$362:$364,$380:$382,$398:$400,$416:$418,$434:$436,$452:$454,$470:$472
5  $2:$2 $3:$3 $4:$4 $20:$20 $21:$21 $22:$22 $38:$38 $39:$39 $40:$40 $56:$56 $57:$57 $58:$58 $74:$74 $75:$75 $76:$76 $92:$92 $93:$93 $94:$94 $110:$110 $111:$111 $112:$112 $128:$128 $129:$129 $130:$130 $146:$146 $147:$147 $148:$148 $164:$164 $165:$165

Line 1 shows that I have 5690 data rows. This is many less than you have but this is sufficient to give an adequate indication of performance.

Line 2 is the result of:

Set RngTgt = .Range(.Rows(2), .Rows(RowMax)).SpecialCells(xlCellTypeVisible)
Debug.Print "2  RngTgt " & RngTgt.Address

Note that the range addresses are $2:$4, $20:$22 and so on. Note also the line is truncated. The Address property gives as many whole ranges as possible such that the total length of the string is less than 255 characters.

Line 3 is the result of:

Debug.Print "3  ";
For Each RngCrnt In RngTgt
  Debug.Print RngCrnt.Address & " ";
  Count = Count + 1
  If Count = 30 Then Exit For
Next
Debug.Print

Note that although the range addresses were for entire rows, For Each returns individual cells. Note also that although I have 26 columns of data, the cells returned include AA2, AB2 and so on.

Line 4 is the result of:

Set RngTgt = RngTgt.EntireRow
Debug.Print "4  RngTgt " & RngTgt.Address

It would appear, the new Set RngTgt has had no effect.

However line 5, which was created in the same way as row 3, contains row instead of cells. If you use Excel 2003, processing the modified RngTgt will be 256 times faster than processing the unmodified RngTgt . If you use a later version of Excel, it will be 16,384 faster.

The remainder of the macro identifies the largest range by each of two different techniques. The first technique checks the Hidden property of each row. The second technique uses the modified RngTgt . The output is:

Duration 1: 0.073
Largest range 579 to 582
Duration 2: 0.003
Largest range 579 to 582

I believe duration 1 demonstrates technique 1 would give acceptable results but technique 2 is obviously substantially faster.

The remainder of the macro is:

    StartTime = Timer

    RowCrntRangeStart = 0           ' No current visible range
    RowLargestRangeStart = 0        ' No range found so far

    RowCrnt = 2
    Do While True
      ' Search for visible row
      Do While True
        If Not .Rows(RowCrnt).Hidden Then
          RowCrntRangeStart = RowCrnt
          Exit Do
        End If
        RowCrnt = RowCrnt + 1
        If RowCrnt > RowMax Then
          Exit Do
        End If
      Loop

      If RowCrntRangeStart = 0 Then
        ' No unprocessed visible row found
        Exit Do
      End If

      ' Search for invisble row
      Do While True
        If .Rows(RowCrnt).Hidden Then
          ' Visible range is RowCrntRangeStart to RowCrnt-1
          If RowLargestRangeStart = 0 Then
            ' This is the first visible range
            RowLargestRangeStart = RowCrntRangeStart
            RowLargestRangeEnd = RowCrnt - 1
            NumRowsInLargestRange = RowLargestRangeEnd - RowLargestRangeStart + 1
          Else
            ' Check for new range being larger thsn previous
            If RowCrnt - RowCrntRangeStart > NumRowsInLargestRange Then
              ' This visible range is larger than previous largest
              RowLargestRangeStart = RowCrntRangeStart
              RowLargestRangeEnd = RowCrnt - 1
              NumRowsInLargestRange = RowLargestRangeEnd - RowLargestRangeStart + 1
            End If
          End If
          RowCrntRangeStart = 0     ' Not within visible range
          RowCrnt = RowCrnt + 1     ' Step over first row of invisible range
          Exit Do
        End If
        RowCrnt = RowCrnt + 1
        If RowCrnt > RowMax Then
          Exit Do
        End If
      Loop

      If RowCrnt > RowMax Then
        Exit Do
      End If

    Loop

    Debug.Print "Duration 1: " & Format(Timer - StartTime, "##0.####")
    Debug.Print "Largest range " & RowLargestRangeStart & " to " & RowLargestRangeEnd

  End With

  StartTime = Timer

  RowCrntRangeStart = 0           ' No current visible range
  RowLargestRangeStart = 0        ' No range found so far

  For Each RngCrnt In RngTgt
    If RowCrntRangeStart = 0 Then
      ' Start of visible range
      RowPrev = RngCrnt.Row
      RowCrntRangeStart = RowPrev
    Else
      ' Already within visible range
      If RowPrev + 1 = RngCrnt.Row Then
        ' Within same visible range
        RowPrev = RngCrnt.Row
      Else
        ' Have start of new visible range
        ' Last visible range was RowCrntRangeStart to Rowprev
        If RowLargestRangeStart = 0 Then
          ' This is the first visible range
          RowLargestRangeStart = RowCrntRangeStart
          RowLargestRangeEnd = RowPrev
          NumRowsInLargestRange = RowLargestRangeEnd - RowLargestRangeStart + 1
        Else
          ' Check for new range being larger thsn previous
          If RowPrev - RowCrntRangeStart + 1 > NumRowsInLargestRange Then
            ' This visible range is larger than previous largest
            RowLargestRangeStart = RowCrntRangeStart
            RowLargestRangeEnd = RowPrev
            NumRowsInLargestRange = RowLargestRangeEnd - RowLargestRangeStart + 1
          End If
        End If
        RowCrntRangeStart = RngCrnt.Row       ' Start of new visible range
        RowPrev = RngCrnt.Row
      End If
    End If
  Next

  Debug.Print "Duration 2: " & Format(Timer - StartTime, "##0.####")
  Debug.Print "Largest range " & RowLargestRangeStart & " to " & RowLargestRangeEnd

End Sub

I hope technique 2 is helpful for you. It will certainly be helpful for me.