Get filtered range into array

R

RB Smissaert

Is there any better way (faster mainly or neater) to get the values of a
filtered range into an array than copying that filtered range to a different
sheet and then getting the pasted values into an array?
Currently I use this code, but I have a feeling there must be better way,
avoiding the copy:

Function getFilteredRows(ByRef rngFilter As Range, _
Optional bHeader As Boolean, _
Optional oSheet As Worksheet) As Variant

Dim shNew As Worksheet
Dim lRowCount As Long
Dim lColCount As Long
Dim arr

If oSheet Is Nothing Then
Set oSheet = ActiveSheet
End If

If oSheet.FilterMode = False Then
'early exit if the sheet has no active filter
'--------------------------------------------
getFilteredRows = rngFilter
Exit Function
End If

Application.ScreenUpdating = False

lColCount = rngFilter.Columns.Count
lRowCount = rngFilter.SpecialCells(xlCellTypeVisible).Cells.Count \
lColCount

For Each shNew In ActiveWorkbook.Worksheets
If shNew.Name = "ZYQYZ" Then
shNew.Delete
End If
Next shNew

Set shNew = ActiveWorkbook.Sheets.Add
shNew.Name = "ZYQYZ"

rngFilter.Copy Sheets("ZYQYZ").Cells(1)

With Sheets("ZYQYZ")
If bHeader Then
arr = .Range(.Cells(2, 1), .Cells(lRowCount, lColCount))
Else
arr = .Range(.Cells(1), .Cells(lRowCount, lColCount))
End If
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With

Application.ScreenUpdating = True

getFilteredRows = arr

End Function


One way would be just looping through the filtered range and only put values
in the array
of rows that are not hidden, but that is a lot slower than the above code.


RBS
 
R

RB Smissaert

This is a bit better than the posted code as we don't need to name the new
sheet:

Function getFilteredRows(ByRef rngFilter As Range, _
Optional bHeader As Boolean, _
Optional oSheet As Worksheet) As Variant

Dim shNew As Worksheet
Dim lRowCount As Long
Dim lColCount As Long
Dim arr

If oSheet Is Nothing Then
Set oSheet = ActiveSheet
End If

If oSheet.FilterMode = False Then
'early exit if the sheet has no active filter
'--------------------------------------------
getFilteredRows = rngFilter
Exit Function
End If

Application.ScreenUpdating = False

lColCount = rngFilter.Columns.Count
lRowCount = rngFilter.SpecialCells(xlCellTypeVisible).Cells.Count \
lColCount

Set shNew = ActiveWorkbook.Sheets.Add

rngFilter.Copy shNew.Cells(1)

With shNew
If bHeader Then
arr = .Range(.Cells(2, 1), .Cells(lRowCount, lColCount))
Else
arr = .Range(.Cells(1), .Cells(lRowCount, lColCount))
End If
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With

Application.ScreenUpdating = True

getFilteredRows = arr

End Function


RBS
 
R

RB Smissaert

Code could be tidied up a bit more:

Function getFilteredRows(ByRef rngFilter As Range, _
Optional bHeader As Boolean, _
Optional oSheet As Worksheet) As Variant

Dim shNew As Worksheet
Dim lRowCount As Long
Dim lColCount As Long

If oSheet Is Nothing Then
Set oSheet = ActiveSheet
End If

If oSheet.FilterMode = False Then
'early exit if the sheet has no active filter
'--------------------------------------------
getFilteredRows = rngFilter
Exit Function
End If

Application.ScreenUpdating = False

lColCount = rngFilter.Columns.Count
lRowCount = rngFilter.SpecialCells(xlCellTypeVisible).Cells.Count \
lColCount

Set shNew = ActiveWorkbook.Sheets.Add

rngFilter.Copy shNew.Cells(1)

With shNew
If bHeader Then
getFilteredRows = .Range(.Cells(2, 1), .Cells(lRowCount, lColCount))
Else
getFilteredRows = .Range(.Cells(1), .Cells(lRowCount, lColCount))
End If
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With

Application.ScreenUpdating = True

End Function


RBS
 
R

RB Smissaert

Just some further streamlining of this code.
Still not found a better way to handle this.

Function getFilteredRows(rngFilter As Range, _
Optional bOmitHeader As Boolean, _
Optional oSheet As Worksheet) As Variant

Dim shNew As Worksheet

If oSheet Is Nothing Then
Set oSheet = ActiveSheet
End If

If oSheet.FilterMode = False Then
'early exit if the sheet has no active filter
'--------------------------------------------
getFilteredRows = rngFilter
Exit Function
End If

Application.ScreenUpdating = False

Set shNew = ActiveWorkbook.Sheets.Add

rngFilter.Copy shNew.Cells(1)

With shNew

If bOmitHeader Then
getFilteredRows = .Range(.Cells(2, 1), .Cells(2,
1).SpecialCells(xlLastCell))
Else
getFilteredRows = .UsedRange
End If

Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True

End With

Application.ScreenUpdating = True

End Function


RBS
 
J

Jim Cone

Not a real solution, but it was an interesting exercise...
'--
Sub TestIt()
Dim vFilterRange As Variant
Dim strFilterAddress As String
Dim x As Long
Dim y As Long

'The range address has a length limitation of ~ 256 characters.
'So the following only works on a small filtered range.
'You must specify the filtered column number.

strFilterAddress = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Address
vFilterRange = VBA.Split(strFilterAddress, ",", -1, vbBinaryCompare)

x = LBound(vFilterRange, 1)
y = UBound(vFilterRange, 1)
MsgBox "Lower bound is: " & x & vbCr & "Upper bound is: " & y

vFilterRange = VBA.Join(vFilterRange, ":")
vFilterRange = VBA.Split(vFilterRange, ":", -1, vbBinaryCompare)

x = LBound(vFilterRange, 1)
y = UBound(vFilterRange, 1)
MsgBox "Lower bound is: " & x & vbCr & "Upper bound is: " & y
End Sub

--
Jim Cone
Portland, Oregon USA
http://www.mediafire.com/PrimitiveSoftware

..
..
..

"RB Smissaert" <[email protected]>
wrote in message
Just some further streamlining of this code.
Still not found a better way to handle this.

Function getFilteredRows(rngFilter As Range, _
Optional bOmitHeader As Boolean, _
Optional oSheet As Worksheet) As Variant

Dim shNew As Worksheet

If oSheet Is Nothing Then
Set oSheet = ActiveSheet
End If

If oSheet.FilterMode = False Then
'early exit if the sheet has no active filter
'--------------------------------------------
getFilteredRows = rngFilter
Exit Function
End If

Application.ScreenUpdating = False

Set shNew = ActiveWorkbook.Sheets.Add

rngFilter.Copy shNew.Cells(1)

With shNew
If bOmitHeader Then
getFilteredRows = .Range(.Cells(2, 1), .Cells(2, 1).SpecialCells(xlLastCell))
Else
getFilteredRows = .UsedRange
End If

Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
End Function

RBS
 
R

RB Smissaert

Hi Jim,

As you say, interesting, but not usable.
Peculiar that there is no better way to get the filtered
data other than copying to another sheet.

RBS
 
D

Dave Peterson

One could loop through the visible rows of the original filtered data and just
add the values to an array.

This may be better (depending on the definition of better <vbg>).
 
D

Dave Peterson

I would think it would depend on the results of a filter. If the number of
visible rows is small (whatever that means), I bet it's much faster.
 
P

Peter T

Hi Bart,

Think I agree with Dave, with a small range it would be faster.

OTH, you'd save some time if you use a permanent dummy sheet in an addin,
rather than creating/deleting a sheet each time.

Regards,
Peter T
 
R

RB Smissaert

OK, had a look at looping throug the range, looking for non-hidden rows and
putting that
in an array and indeed with a small number of rows that is faster than
pasting and copying the range.
When about half the rows are hidden (and with a range one column wide) the
cut-off point is about 2500
rows. So above that the method with paste and copy is faster.
Keeping the same sheet rather than adding and deleting a sheet doesn't
really make much difference.

Function getFilteredRows2(rngFilter As Range, _
Optional bOmitHeader As Boolean) As Variant


Dim r As Long
Dim n As Long
Dim c As Long
Dim x As Long
Dim lFirstRow As Long
Dim arr() As Variant
Dim lRows As Long
Dim lColumns As Long

lRows = rngFilter.Rows.Count
lColumns = rngFilter.Columns.Count

If bOmitHeader Then
lFirstRow = 2
Else
lFirstRow = 1
End If

'count non-hidden rows
'---------------------
For r = lFirstRow To lRows
If rngFilter.Cells(r, 1).EntireRow.Hidden = False Then
n = n + 1
End If
Next r

'size the final array
'--------------------
ReDim arr(1 To n, 1 To lColumns) As Variant

'get the data of the non-hidden rows
'-----------------------------------
If lColumns = 1 Then
For r = lFirstRow To lRows
If rngFilter.Cells(r, 1).EntireRow.Hidden = False Then
x = x + 1
arr(x, 1) = rngFilter.Cells(r, 1)
End If
Next r
Else
For r = lFirstRow To lRows
If rngFilter.Cells(r, 1).EntireRow.Hidden = False Then
x = x + 1
For c = 1 To lColumns
arr(x, c) = rngFilter.Cells(r, c)
Next c
End If
Next r
End If

getFilteredRows2 = arr

End Function



RBS


RB Smissaert said:
OK, will test the 2 methods and see how they compare.

RBS
Click to expand...
 
P

Peter T

A few simple changes seem to speed things up considerably. In particular
only read each hidden property once, also read entire individual rows to an
array, then copy that to the main array. Anything to reduce reading
individual cells!

Function getFilteredRows3(rngFilter As Range, _
Optional bOmitHeader As Boolean) As Variant

Dim r As Long
Dim n As Long
Dim c As Long
Dim x As Long
Dim lFirstRow As Long
Dim arr() As Variant
Dim lRows As Long
Dim lColumns As Long

lRows = rngFilter.Rows.Count
lColumns = rngFilter.Columns.Count

If bOmitHeader Then
lFirstRow = 2
Else
lFirstRow = 1
End If

'count non-hidden rows
'---------------------
ReDim bArrVis(lFirstRow To lRows) As Boolean

For r = lFirstRow To lRows
If rngFilter.Cells(r, 1).EntireRow.Hidden = False Then
n = n + 1
bArrVis(r) = True
End If
Next r

'size the final array
'--------------------
ReDim arr(1 To n, 1 To lColumns) As Variant

'get the data of the non-hidden rows
'-----------------------------------
If lColumns = 1 Then
For r = lFirstRow To lRows
'If rngFilter.Cells(r, 1).EntireRow.Hidden = False Then
If bArrVis(r) Then
x = x + 1
arr(x, 1) = rngFilter.Cells(r, 1)
End If
Next r
Else
ReDim arrRow(1 To rngFilter.Columns.Count)
For r = lFirstRow To lRows
'If rngFilter.Cells(r, 1).EntireRow.Hidden = False Then
If bArrVis(r) Then
x = x + 1
arrRow = rngFilter.Rows(r).Cells.Value
For c = 1 To lColumns
' arr(x, c) = rngFilter.Cells(r, c)
arr(x, c) = arrRow(1, c)
Next c
End If
Next r
End If

getFilteredRows3 = arr

End Function

Of course the proportion of filtered/hidden rows and number of columns would
be factors either way.

Regards,
Peter T

PS only very lightly tested!



RB Smissaert said:
OK, had a look at looping throug the range, looking for non-hidden rows
and putting that
in an array and indeed with a small number of rows that is faster than
pasting and copying the range.
When about half the rows are hidden (and with a range one column wide) the
cut-off point is about 2500
rows. So above that the method with paste and copy is faster.
Keeping the same sheet rather than adding and deleting a sheet doesn't
really make much difference.

Function getFilteredRows2(rngFilter As Range, _
Optional bOmitHeader As Boolean) As Variant


Dim r As Long
Dim n As Long
Dim c As Long
Dim x As Long
Dim lFirstRow As Long
Dim arr() As Variant
Dim lRows As Long
Dim lColumns As Long

lRows = rngFilter.Rows.Count
lColumns = rngFilter.Columns.Count

If bOmitHeader Then
lFirstRow = 2
Else
lFirstRow = 1
End If

'count non-hidden rows
'---------------------
For r = lFirstRow To lRows
If rngFilter.Cells(r, 1).EntireRow.Hidden = False Then
n = n + 1
End If
Next r

'size the final array
'--------------------
ReDim arr(1 To n, 1 To lColumns) As Variant

'get the data of the non-hidden rows
'-----------------------------------
If lColumns = 1 Then
For r = lFirstRow To lRows
If rngFilter.Cells(r, 1).EntireRow.Hidden = False Then
x = x + 1
arr(x, 1) = rngFilter.Cells(r, 1)
End If
Next r
Else
For r = lFirstRow To lRows
If rngFilter.Cells(r, 1).EntireRow.Hidden = False Then
x = x + 1
For c = 1 To lColumns
arr(x, c) = rngFilter.Cells(r, c)
Next c
End If
Next r
End If

getFilteredRows2 = arr

End Function



RBS
Click to expand...
 
R

RB Smissaert

Had a look at reading the hidden property only once
and storing in an array, but didn't see much difference,
but will test again. Didn't look though at putting rows
in an array and looping through that row array rather than
the range and will try that.

RBS
 
R

RB Smissaert

Remember now why I didn't try putting row range
in an array and reading that row array. In my particular
situation the range is nearly always one column wide,
so in that case I thought there will be no gain.

RBS
 
R

RB Smissaert

Done some testing and fastest is to store the hidden row property in a
boolean array
and also to read the whole range (not row by row) in an array:

Function getFilteredRows4(rngFilter As Range, _
Optional bOmitHeader As Boolean) As Variant


Dim r As Long
Dim n As Long
Dim c As Long
Dim x As Long
Dim lFirstRow As Long
Dim arrRange() As Variant
Dim arr() As Variant
Dim arrVisibleRows() As Boolean
Dim lRows As Long
Dim lColumns As Long

lRows = rngFilter.Rows.Count
lColumns = rngFilter.Columns.Count

If bOmitHeader Then
lFirstRow = 2
Else
lFirstRow = 1
End If

'put the range in an array
'-------------------------
arrRange = rngFilter

'setup a boolean array to store non-hidden rows
'----------------------------------------------
ReDim arrVisibleRows(lFirstRow To lRows)

'count non-hidden rows and store in Boolean array
'------------------------------------------------
For r = lFirstRow To lRows
If rngFilter.Cells(r, 1).EntireRow.Hidden = False Then
n = n + 1
arrVisibleRows(r) = True
End If
Next r

'size the final array
'--------------------
ReDim arr(1 To n, 1 To lColumns) As Variant

'get the data of the non-hidden rows
'-----------------------------------
If lColumns = 1 Then
For r = lFirstRow To lRows
If arrVisibleRows(r) Then
x = x + 1
arr(x, 1) = arrRange(r, 1)
End If
Next r
Else
For r = lFirstRow To lRows
If arrVisibleRows(r) Then
x = x + 1
For c = 1 To lColumns
arr(x, c) = arrRange(r, c)
Next c
End If
Next r
End If

getFilteredRows4 = arr

End Function


Can't see much scope now to make this faster.


RBS
 
D

Dave Peterson

You can loop through the visible rows of the filtered range without looking at
each row to see its "hiddenness":

Option Explicit
Sub testme()

Dim VisRng As Range
Dim wks As Worksheet
Dim myArr As Variant
Dim rCtr As Long
Dim cCtr As Long
Dim myCell As Range

Set wks = Worksheets("Sheet1")

With wks
With .AutoFilter.Range
With .Columns(1)
If .Cells.SpecialCells(xlCellTypeVisible).Cells.Count = 1 Then
MsgBox "only headers visible"
Exit Sub 'do nothing
End If

Set VisRng = .Resize(.Rows.Count - 1).Offset(1, 0) _
.Cells.SpecialCells(xlCellTypeVisible)
End With

ReDim myArr(1 To VisRng.Cells.Count, 1 To .Columns.Count)

rCtr = 0
For Each myCell In VisRng.Cells
rCtr = rCtr + 1
For cCtr = 1 To .Columns.Count
myArr(rCtr, cCtr) = myCell.Offset(0, cCtr - 1).Value
Next cCtr
Next myCell
End With
End With
End Sub

I didn't do any comparison to see what is faster.
 
P

Peter T

The boolean array is exactly what I did. However I also found it faster to
read individual rows to an array, assuming of course the range is more than
one column wide.

FWIW I found the example I posted between 2 to 4 times faster depending on
the test range.

Regards,
Peter T
 
P

Peter T

Hi Dave,

FWIW I find SpecialCells can be extremely slow if trying to create a large
multi-area range.

Regards,
Peter T
 
R

RB Smissaert

read individual rows to an array

Bit faster though to read just the whole range into an array.
Never found something 4 times faster, but that may have to do with the data
we are looking at.

RBS
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Export from EXcel to jpg with 2007 4
Baffled with assignment of range to array why won't it work??? Anyhelp appreciated 4
Cells range into an array, then into msgbox 7
Loop is slow trying array code 17
Cell values to an array, then array transpose to another workbook 8
Error trying to write array to range 5
Convert list to UPPER, lower & Proper cases. 21
Tried and true copy code lines fail me here 7

Top