How to store filtered ranges into array?

Question

Me scratching my head completing this vba script of mine and got stuck:

In sheet1, I have a large table (non-structured) ranged A1:BY1200, row 1 contains headers, which is filtered. Now i need to only store the filtered ranges into array and write the array data back to a different workbook. Below are my half-complete codes for the said goal:

My puzzles:

1. I am not familiar with looping through the filtered range and storing them into array.
2. I also need the last part to be complete for writing the array data (the filtered range) back to, say, sheet2 starting cell A1.

I have already read through a few posts of similar scenarios but none fully meets all the requirements in my case.Someone suggests in other posts to use the Areas method when looping thru the filtered range for recording into array.

Many thanks in advance.

Note: After filtered, there are non-adjacent rows in the filtered range

    Sub StoreFilteredRangeInArray()
    Dim rCell as Range, rData as Range, rArea as Range
    Dim i as Long
    
    with Activesheetset 
    set rData = .range("A1").CurrentRegion
    
    Dim rFiltered as Range
    rData.autofilter Field:=1, Criteria1:="<>"
    
    with rData
    set rFiltered = .offset(1,0).Resize(.Rows.count -1, .Column.count).SpecialCells(xlCellTypeVisible)
    end with

    Dim myArray() as variant
    ...(get stuck here)
    
    end with
    End Sub

Answer 1

rFiltered is a non-contiguous range. If you check the address (eg using the debugger), it will contain something like $A$2:$H$9,$A$11:$H$12,$A$16:$H$21. In my example have 3 blocks of data, (row 2-9, row 11-12 and row 16-21).

The data of non-contiguous ranges cannot be copied in one go. Instead, you need to look at every block (in Excel-terms, "area") separately.

You can access the areas of a range using the areas-property of a range. In our example, we have 3 areas in rFiltered. For information: Those areas itself are again ranges, and if a Range is contiguous, it will have exactly one member in areas.

You have now the choice of either creating a complete array holding all data of all areas and write that into your destination sheet in one go, or you copy the areas one by one into the destination.

Version 1: Copy all data into an array.
Problem is that you don't know how many rows you have, and you need that information to dimension your array. Therefore I suggest to loop twice over the areas, first iteration is to get the number of rows, and after that copy the data:

Dim rowCount As Long, area As Range
For Each area In rFiltered.Areas
    rowCount = rowCount + area.Rows.Count
Next
ReDim filteredData(1 To rowCount, 1 To rFiltered.Columns.Count)

Unfortunately, in VBA no command exists to copy all data of an array into another array in one go, so we have to loop over all rows and columns manually:

Dim dataRow As Long
For Each area In rFiltered.Areas
    Dim areaData As Variant, areaRow As Long, col As Long
    areaData = area.Value  ' Copy Area data into temp. Array
    ' Copy temp array into final array
    For areaRow = 1 To UBound(areaData, 1)
        dataRow = dataRow + 1
        For col = 1 To UBound(areaData, 2)
            filteredData(dataRow, col) = areaData(areaRow, col)
        Next col
    Next areaRow
Next

And with that, you can write the final data into your destination sheet in one go:

With ThisWorkbook.Sheets("Sheet2")
    .UsedRange.Clear
    .Range("A1").Resize(UBound(filteredData, 1), UBound(filteredData, 2)) = filteredData
End With

Version 2: Copy data area by area, without using arrays
The code for this is easier, but you will not have an array with all the data.

With ThisWorkbook.Sheets("Sheet2")
    .UsedRange.Clear
    Dim area As Range, destRow As Long
    destRow = 1
    For Each area In rFiltered.Areas
        .Cells(destRow, 1).Resize(area.Rows.Count, area.Columns.Count).Value = area.Value
        destRow = destRow + area.Rows.Count
    Next
End With

Answer 2

Autofiltered Values to Array

Main (A Common Scenario)

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:       ... Copies auto-filtered values from one sheet to another...
' Calls:        RefAutoFilteredRange
'               GetAutoFilteredRange
'                   GetRange
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub CopyValues()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Sheets("Sheet1")
    
    Dim srg As Range: Set srg = RefAutoFilteredRange(sws, 1, "<>")
    If srg Is Nothing Then Exit Sub
    
    Dim dData() As Variant: dData = GetAutoFilteredRange(srg)
    
    Dim dws As Worksheet: Set dws = wb.Sheets("Sheet2")
    Dim drg As Range:
    Set drg = dws.Range("A2").Resize(UBound(dData, 1), UBound(dData, 2))
    
    drg.Value = dData
    
    ' Or:
    'PrintData dData
    
End Sub

Help

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      References an auto-filtered range of an unstructured table
'               starting in cell A1 of a given worksheet.
' Remarks:      It turns off auto-filtering, filters the table and
'               after referencing the range, turns off auto-filtering.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefAutoFilteredRange( _
    ByVal ws As Worksheet, _
    ByVal Field As Long, _
    ByVal CriteriaString As String) _
As Range
    Const PROC_TITLE As String = "Reference an Autofiltered Range"
    
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
    Dim drg As Range: Set drg = rg.Resize(rg.Rows.Count - 1).Offset(1)
    
    rg.AutoFilter Field, CriteriaString
    
    Dim vrg As Range
    On Error Resume Next
        Set vrg = drg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    ws.AutoFilterMode = False
    
    If vrg Is Nothing Then
        MsgBox "No filtered cells found.", vbExclamation, PROC_TITLE
        Exit Function
    End If
    
    Set RefAutoFilteredRange = vrg
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of an auto-filtered range
'               in a 2D one-based array.
' Remarks:      An auto-filtered range is a possibly non-contiguous range
'               whose areas have the same first and last columns.
' Calls:        GetRange
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetAutoFilteredRange( _
    ByVal vrg As Range) _
As Variant
    Const PROC_TITLE As String = "Get Autofiltered Range"
    
    If vrg Is Nothing Then
        MsgBox "The range is 'Nothing'.", vbExclamation, PROC_TITLE
        Exit Function
    End If

    Dim crg As Range: Set crg = Intersect(vrg, vrg.Cells(1).EntireColumn)
    Dim cCount As Long: cCount = vrg.Columns.Count
    
    Dim dData() As Variant: ReDim dData(1 To crg.Cells.Count, 1 To cCount)
    
    Dim arg As Range, aData() As Variant, ar As Long, dr As Long, c As Long
    
    For Each arg In vrg.Areas
        aData = GetRange(arg)
        For ar = 1 To arg.Rows.Count
            dr = dr + 1
            For c = 1 To cCount
                dData(dr, c) = aData(ar, c)
            Next c
        Next ar
    Next arg
    
    GetAutoFilteredRange = dData
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a range in a 2D one-based array.
' Remarks:      Only the first area of the range is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange(ByVal rg As Range) As Variant
    Const PROC_TITLE As String = "Get Range"
    
    If rg Is Nothing Then
        MsgBox "The range is 'Nothing'.", vbExclamation, PROC_TITLE
        Exit Function
    End If
    
    Dim Data() As Variant
    
    If rg.Cells.CountLarge = 1 Then
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
    Else
        Data = rg.Value
    End If
    
    GetRange = Data
End Function

Print Data Result

• You can find the PrintData procedure here.

PrintData Result
1 2 10
2 9  2
3 5  3
4 1  4

Answer 3

Tiny extension to FunThomas'es Version 2

Just for (further) fun an approach

• using a temporary sheet (c.f. function newWS()) and
• assigning the whole used range to a datafield array:

Function AreasToArr(rng As Range) As Variant
    With newWS()        ' << create temporary sheet via newWS()
    'a) copy each area values to temporary sheet
        Dim area As Range
        For Each area In rng.Areas
            Dim tmp As Variant: tmp = area.Value2
            Dim cnt As Long:    cnt = UBound(tmp)
            Dim cur As Long
            ' add area values (to last block)
            .Range("A" & cur + 1).Resize(cnt, UBound(tmp, 2)) = tmp
            'increment current row number
            cur = cur + cnt
        Next
    'b) assign entire range to datafield array
        AreasToArr = .UsedRange.Value2
    'c) delete temporary sheet
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
    End With
    
End Function

Create a new worksheet

Function newWS() As Worksheet
    Dim wb As Workbook: Set wb = ThisWorkbook
    Set newWS = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
End Function