Dynamic Array Sizing

I'm sure it's something small, but I can't seem to get over the hump.

A worksheet range of 1 to n rows x 1 to 10 columns is passed to an array. First column is tested as matching a global named range within workbook (string = string). If TRUE, 7 of the 10 columns in a different order are passed to a second array.

How do I resize the 2nd array (1 to n + 1) to accept each new instance of TRUE above? I am currently running the same test twice, the first time to count the instances of TRUE so that I can just pre-size the array, and then again to pass the data in. This seems ineffecient to me.

Thanks,

AS

Sub CompileData()
'*************************************************************************
Dim wb                      As Workbook     'Declare wb
Dim wsData                  As Worksheet    'Declare "Data" ws
Dim Arr1()                  As Variant      'Array of all data
Dim Arr2()                  As Variant      'Array of applicable data
Dim strUserSub              As String       'String of user choice (dropdown)
Dim strFind                 As String       'String to be found
Dim rngFind                 As Range        'Location of table
Dim rngSource               As Range        'Range of all names in table
Dim rngArr2                 As Range        'Define range to accept array passback
Dim n                       As Integer      'Used as count w/in arr1
Dim i                       As Integer      'Used as count w/in arr2
'*************************************************************************
Set wb = ThisWorkbook
Set wsData = wb.Sheets("Data")
strFind = "Example String"
strUserSub = CStr(Range("User.Choice"))
    
    '~~> Find string, offset 2 x 2, resize range to contiguous end
    With wsData
        Set rngFind = .Range("E:E").Find(strFind, , xlValues, xlWhole).Offset(2, 2)
        Set rngSource = .Range(rngFind, rngFind.End(xlDown)).Resize(, 10)
        'rngSource.Select
    End With
    
    '~~> Pass range to array for compilation
    Arr1 = rngSource.Value
    
    '~~> Assign integer to count of list
    i = 0
    For n = LBound(Arr1) To UBound(Arr1)
        '~~> Test 1st column of array as being equal to user choice
        If Arr1(n, 1) = strUserSub Then
            '~~> Set new increment counter for true above
            i = i + 1
        End If
    Next
    
    ReDim Arr2(1 To i, 1 To 7)
    
    i = 0
    For n = LBound(Arr1) To UBound(Arr1)
        '~~> Test 1st column of array as being equal to user choice
        If Arr1(n, 1) = strUserSub Then
            '~~> Set new increment counter for true above
            i = i + 1
            '~~> If same, send to new array
            Arr2(i, 1) = Arr1(n, 3)
            Arr2(i, 2) = Arr1(n, 6)
            Arr2(i, 3) = Arr1(n, 7)
            Arr2(i, 4) = Arr1(n, 8)
            Arr2(i, 5) = Arr1(n, 2)
            Arr2(i, 6) = Arr1(n, 9) 
            Arr2(i, 7) = Arr1(n, 10)
        End If
    Next

   '~~> Pass back to worksheet
    With wsData
        Set rngArr2 = rngFind.Offset(, 12).Resize(i, 7)
        rngArr2 = Arr2
    End With
    
End Sub

Can't you run a countif over the first column rather than a loop? That said, I'm not sure which would be faster. Looping over arrays is extremely fast, there's a discussion here on something similar http://stackoverflow.com/questions/1...rtain-criteria

EDIT: Actually, why not make the second array the same height as rngSource, you can then just resize the range you dump into to the matches found, that way it will only dump the top rows that match.

you can also use an array of arrays for the second array and use redim preserve once at the end to resize it down to only the used elements

Like this:

With wsData
        Set rngFind = .Range("E:E").Find(strFind, , xlValues, xlWhole).Offset(2, 2)
        Set rngSource = .Range(rngFind, rngFind.End(xlDown)).Resize(, 10)
    End With
    
    '~~> Pass range to array for compilation
    Arr1 = rngSource.Value
    
    ReDim Arr2(1 To UBound(Arr1), 1 To 7)
    
    i = 0
    For n = LBound(Arr1) To UBound(Arr1)
        '~~> Test 1st column of array as being equal to user choice
        If Arr1(n, 1) = strUserSub Then
            '~~> Set new increment counter for true above
            i = i + 1
            '~~> If same, send to new array
            Arr2(i, 1) = Arr1(n, 3)  
            Arr2(i, 2) = Arr1(n, 6) 
            Arr2(i, 3) = Arr1(n, 7)
            Arr2(i, 4) = Arr1(n, 8)
            Arr2(i, 5) = Arr1(n, 2)
            Arr2(i, 6) = Arr1(n, 9)
            Arr2(i, 7) = Arr1(n, 10)
        End If
    Next

    ReDim Preserve Arr2(1 To i, 1 To 7)

I'm getting subscript out of range on the ReDim Preserve line.