T
he macro in the
“Copy Filtered data using Autofilter in VBA into Array” transfers the filtered data
using autofilter comment to an array. The imperfect thing about it is that the
transferred array contains the blank data in it because the size of the array
equals to the size of the whole filtered range.
The easier way to solve the issue is to copy the non
blank data into the new array.
Sub main()
Dim FiltResult() As Variant
Dim Filtersheet As Worksheet
Dim FiltRange As Range
Dim FiltField As Integer
Dim FiltCrit As Variant
Set Filtersheet = sheets("PStream")
Set FiltRange = Filtersheet.Range("C6:F7352")
FiltField = 1
FiltCrit = 900
FiltResult = Copyfilter(Filtersheet, FiltRange, FiltField, FiltCrit)
'''''
''''Codes related with the filtered result
''''
End Sub
Function Copyfilter(Sht As Worksheet, Rng
As Range, FField As Integer, Crit As Variant)
Dim Arr() As Variant
Dim ArrNew() As Variant
Sht.Select
With Sht
Rng.AutoFilter
RowCount = Rng.Rows.Count
ColCount = Rng.Columns.Count
Count = 1
ReDim Arr(1 To RowCount, 1 To ColCount)
Rng.AutoFilter Field:=FField, Criteria1:=Crit
'------Copy the data to array for
future use
'----Do not include the table tilte
For i = 2 To RowCount
If Rng(i, 1).Rows.Hidden =
False Then
For j = 1 To ColCount
Arr(Count, j) = Rng(i,
j).Value
Next j
Count = Count + 1
End If
Next i
Rng.AutoFilter
End With
'----Copy the nonblank data into a new
array
ReDim ArrNew(1 To Count - 1, 1 To ColCount)
For i = 1 To Count - 1
For j = 1 To ColCount
ArrNew(i, j) = Arr(i, j)
Next j
Next i
'----Transfer the data to the main sub
Copyfilter = ArrNew
End Function
Another way is to using ReDim Preserve Statement. The trick part is that when using Preserve, only the upper bound of the
array can be changed. Otherwise the run time error is shown. I transpose the
array to use the ReDim Preserve Statement to eliminated the un need elements.
Sub main2()
Dim FiltResult() As Variant
Dim Filtersheet As Worksheet
Dim FiltRange As Range
Dim FiltField As Integer
Dim FiltCrit As Variant
Set Filtersheet = sheets("PStream")
Set FiltRange = Filtersheet.Range("C6:F7352")
FiltField = 1
FiltCrit = 9002
FiltResult = Copyfilter(Filtersheet, FiltRange, FiltField, FiltCrit)
'''''
''''Codes related with the filtered result
''''Filter result is transposed array
''''
End Sub
Function Copyfilter(Sht As Worksheet, Rng
As Range, FField As Integer, Crit As Variant)
Dim Arr() As Variant
Sht.Select
With Sht
Rng.AutoFilter
RowCount = Rng.Rows.Count
ColCount = Rng.Columns.Count
Count = 1
ReDim Arr(1 To ColCount, 1 To RowCount)
Rng.AutoFilter Field:=FField, Criteria1:=Crit
'------Copy the data
to array for future use
'------Transpose the array, the
column to row and row to column
For i = 2 To RowCount
If Rng(i, 1).Rows.Hidden =
False Then
For j = 1 To ColCount
Arr(j, Count) = Rng(i,
j).Value
Next j
Count = Count + 1
End If
Next i
Rng.AutoFilter
End With
'Redim the size of array, only keep the
nonblank data
ReDim Preserve Arr(1 To ColCount, 1 To Count - 1)
'----Transfer the data to the main sub
Copyfilter = Arr
End Function
© Copyright
Exceltipsandkeys All Rights Reserved.