After data is filtered and sorted using Sub CreateFilteredandSort
, I'm trying to use
.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Offset(1)
to store the data into an array.
In the array I get only one row.
To get all the data into the array I paste somewhere in the active worksheet then
'Alertnative method
Range("a1").Select
ActiveSheet.Paste
ResultArr = Selection 'This Works fine
What do I correct to prevent the alternative method?
Here the source code
Sub TestCreateandClearFilter()
Dim WS As Worksheet
Dim ResultArr() As Variant
Set WS = ActiveWorkbook.ActiveSheet
IfFilterandSortinWorksheetExistClear WS
CreateFilteredandSort WS, _
WS.Range("Rangedata"), _
"H", _
"F", _
"a", _
WS.Range("RNGA")
'store in Array
'not Working, Only one row is stored
ResultArr = WS.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Offset(1)
WS.Range("Rangedata").Offset(1).SpecialCells(xlCellTypeVisible).Select
ResultArr = Selection
'not Working, Only one row is stored
WS.Range("Rangedata").Offset(1).Copy
'Alertnative method
Range("a1").Select
ActiveSheet.Paste
ResultArr = Selection 'This Works fine
End Sub
Sub CreateFilteredandSort(WS As Worksheet, RangeSelected As Range, _
FilterField11Name As String, FilterField12Name As String, _
FilterField12Criteria As String, Group1Sort As Range)
'
' Create Custom Filter and sort Macro
Dim FilterColumn1 As Variant
Dim arra As Variant
'GetTheOffsetField
'3 required because the range start in column 4
FilterColumn1 = RangeSelected.Rows(1).Find(What:=FilterField11Name, _
LookAt:=xlWhole, SearchOrder:=xlByRows).Column - 3
FilterColumn2 = RangeSelected.Rows(1).Find(What:=FilterField12Name, _
LookAt:=xlWhole, SearchOrder:=xlByRows).Column - 3
' Create the Filter
RangeSelected.AutoFilter Field:=FilterColumn1, Criteria1:="TRUE"
RangeSelected.AutoFilter Field:=FilterColumn2, Criteria1:=FilterField12Criteria
'Sort by group1
WS.AutoFilter.Sort.SortFields.Add2 Key:= _
Group1Sort, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With WS.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sub IfFilterandSortinWorksheetExistClear(WS As Worksheet)
If WS.AutoFilterMode Then Selection.AutoFilter
End Sub
Please, try the next function, able to transform a discontinuous range in a continuous array:
Function arrayFromDiscontRange(rng As Range) As Variant
Dim aR As Range, R As Range, arrInt, arr, i As Long, k As Long
Dim rngInt As Range, count As Long, j As Long
k = 1
'counting range/area rows:________________________________
Set rngInt = Intersect(rng, rng.cells(1, 1).EntireColumn)
For Each aR In rngInt.Areas
If aR.rows.count = 1 Then
count = count + 1
Else
For Each R In aR.cells
count = count + 1
Next
End If
Next
'________________________________________________________
ReDim arr(1 To count, 1 To rng.Columns.count)
For Each aR In rng.Areas
If aR.rows.count = 1 Then
For i = 1 To aR.Columns.count
arr(k, i) = aR.cells(1, i)
Next
k = k + 1
Else
For i = 1 To aR.rows.count
For j = 1 To aR.Columns.count
arr(k, j) = aR.cells(i, j)
Next j
k = k + 1
Next
End If
Next
arrayFromDiscontRange = arr
End Function
It can be called passing a discontinuous range (obtained after filtering), in the next way:
'firstly, filter the range
'
Dim rngArr As Range
Set rngArr = WS.Range("Rangedata").SpecialCells(xlCellTypeVisible)
ResultArr = arrayFromDiscontRange(rngArr)
Dim arrFirstRow
arrFirstRow = Application.Index(ResultArr, 1, 0) 'make a slice for the first array row (1D array)
Debug.Print Join(arrFirstRow, "|") 'see the array first row content in Immediate Window
If you need to skip the first row, the function can be easily transformed to create the array starting from the second (real) range row. First row of the first area will be skipped...
Edited :
The next function is able to return an array starting from a mentioned row:
Function arrFromDiscontRange(rng As Range, Optional startRow As Long = 1) As Variant
Dim aR As Range, R As Range, arrInt, arr, i As Long, k As Long
Dim rngInt As Range, count As Long, j As Long, iStart As Long
k = 1
'counting range/area rows:________________________________
Set rngInt = Intersect(rng, rng.cells(1, 1).EntireColumn)
For Each aR In rngInt.Areas
If aR.rows.count = 1 Then
count = count + 1
Else
For Each R In aR.cells
count = count + 1
Next
End If
Next
'________________________________________________________
ReDim arr(1 To count - startRow + 1, 1 To rng.Columns.count)
For Each aR In rng.Areas
If aR.rows.count = 1 Then
iStart = iStart + 1
If iStart >= startRow Then
For i = 1 To aR.Columns.count
arr(k, i) = aR.cells(1, i)
Next
k = k + 1
End If
Else
For i = 1 To aR.rows.count
iStart = iStart + 1
If iStart >= startRow Then
For j = 1 To aR.Columns.count
arr(k, j) = aR.cells(i, j)
Next j
k = k + 1
End If
Next
End If
Next
arrFromDiscontRange = arr
End Function
It can be called/tested, in your context in the next way:
'firstly, filter the range
'
Dim rngArr As Range
Set rngArr = WS.Range("Rangedata").SpecialCells(xlCellTypeVisible)
ResultArr = arrayFromDiscontRange(rngArr, 2)' it will build the array starting from the second row of the (discontinuous) range.
Dim arrFirstRow
arrFirstRow = Application.Index(ResultArr, 1, 0) 'make a slice for the first array row (1D array)
Debug.Print Join(arrFirstRow, "|") 'see the array first row content in Immediate Window
Please, test it and send some feedback. I had in mind doing such a function and I did it now, seeing your question...
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.