Copy Two dimensional array to another array based on criteria in VBA

Question

I would like to copy data from one sheet to another.

I put the range that I want to copy into an array (LookupSource) because it's faster to work on arrays than looping through cells.

After filling my two dimensional array (LookupSource), I would like to keep only some records based on critieria (Column A = 10000), so I am trying to copy from LookupSource, the rows that fetch this criteria to the two dimensional array (DataToCopy) which will be copied to the destination sheet.

My problem is that I am not able to do that because as it seems I am not able to make a dynamic resize for the first dimension (rows) of the second array (DataToCopy).

Any Idea how to fill DataToCopy from LookupSource based on my condition ?

The error "index out of range" that I am getting is at the Line : ReDim Preserve DataToCopy(1 to j, 1 to 6)

not at first time, but on second time that I enter the For loop after the Next I I suppose it's because the J is variable and I am not allowed to change the first dimension of the array.

How to deal with that ?

Any better Idea from what I am doing ?

to give you an example here is a small part of the sheet that I want to copy (I took only 8 rows, but in real there thousands). I want to copy only the rows that have 10000 in column A.

Here is my code

Dim LookupSource as Variant      
Dim DataToCopy() As Variant        
Dim i As Long
Dim j As Long


With MySheet
'MyRange is a defined name that reprensent column A, B, C, D, E, F
LookupSource = .Range(.Range("MyRange")(1, 1), .Range("MyRange")(8, 6)).Value2

j = 1

For i = LBound(LookupSource) To UBound(LookupSource)

If LookupSource(i, 1) = 10073 Then
ReDim Preserve DataToCopy(1 to j, 1 to 6)
DataToCopy(j, 1) = LookupSource(i, 1)
DataToCopy(j, 2) = LookupSource(i, 2)
DataToCopy(j, 3) = LookupSource(i, 3)
DataToCopy(j, 4) = LookupSource(i, 4)
DataToCopy(j, 5) = LookupSource(i, 5)
DataToCopy(j, 6) = LookupSource(i, 6)
j = j + 1
End If

Next i

end with

Answer 1

How to overcome the restrictions of ReDim Preserve in multidimensional arrays

As mentioned by @ScottCraner, a ReDim Preserve can change only the last dimension of a given (datafield) array. Therefore trying to resize a 2-dimensional array's first dimension (="rows") will fail.

However you can overcome this inconvenience applying the relatively unknown filtering capability of Application.Index() (c.f. section [2]) and profit from the additional bonus of less loops.

Further reading: see Some pecularities of the Application.Index() function

Sub GetRowsEqual10000()
    With Sheet1
        Dim lastRow As Long:  lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        Dim rng     As Range: Set rng = .Range("A2:F" & lastRow)
    End With

    '[1] get data
    Dim data: data = rng

    '[2] rearrange data via Application.Index() instead ReDim Preserve plus loops
    data = Application.Index(data, ValidRows(data, Condition:=10000), Array(1, 2, 3, 4, 5, 6))
End Sub

Help function ValidRows()

Function ValidRows(arr, Condition) As Variant
'Purpose: a) check condition (e.g. values equalling 10000) and b) get valid row numbers c) in a 2-dim vertical array
ReDim tmp(1 To UBound(arr))     ' provide for 1-based 2-dim array
Dim i As Long, ii As Long
For i = 1 To UBound(arr)                ' loop through 1st "column"
    If arr(i, 1) = Condition Then       '   a) check condition 
        ii = ii + 1: tmp(ii) = i        '   b) collect valid row numbers
    End If
Next i
ReDim Preserve tmp(1 To ii)             '   resize tmp array (here the 1st dimension is also the last one:) 
ValidRows = Application.Transpose(tmp)  ' c) return transposed result as 2-dim array
End Function

---

Edit due to comment (2020-04-22)

Short hints to the most frequent use of Application.Index():

Frequently the Application.Index() function is used to get an entire row or column array out of a 2-dim array without need to loop.
Accessing your 1-based 2-dimensional datafield array like that requires to indicate a single row or column number and to set the neighbour argument column or row number to 0 (zero), respectively which might result in e.g.

        Dim horizontal, vertical, RowNumber As Long, ColumnNumber As Long
    RowNumber = 17: ColumnNumber = 4
    horizontal = Application.Index(data, RowNumber, 0)
    vertical   = Application.Index(data, 0, ColumnNumber)

(Addressing a single array element will be done directly, however via data(i,j) instead of a theoretical Application.Index(data, i, j))

How to use Application.Index() for restructuring/filtering purposes:

In order to profit from the advanced possibilities of Application.Index() you need to pass not only the array name (e.g. data), but the row|column arguments as Arrays, e.g.

    data = Application.Index(data, Application.Transpose(Array(15,8,10)), Array(1, 2, 3, 4, 5, 6))

Note that the rows parameter becomes a "vertical" 2-dim array by transposition, where Array(15,8,10) would even change the existing row order (in the example code above this is done in the last code line within the ValidRows() function). The columns argument Array(1,2,3,4,5,6) on the other hand remains "flat" or "horizontal" and allows to get all existing column values as they are.

So you eventually you are receiving any data elements within the given element indices (think them as coordinates in a graphic).

Answer 2

Range Lookup Function

The Code

Option Explicit

'START ****************************************************************** START'
' Purpose:      Filters a range by a value in a column and returns the result  '
'               in an array ready to be copied to a worksheet.                 '
'******************************************************************************'
Function RangeLookup(LookUpValue As Variant, LookupRange As Range, _
  Optional LookupColumn As Long = 1) As Variant

    Dim LookUpArray As Variant    ' LookUp Array
    Dim DataToCopy As Variant     ' DataToCopy (RangeLookup) Array
    Dim countMatch As Long        ' DataToCopy (RangeLookUp) Rows Counter
    Dim r As Long, c As Long      ' Row and Column Counters

    ' Check the arguments.
    Select Case VarType(LookUpValue)
         Case 2 To 8, 11, 17
         Case Else: Exit Function
    End Select
    If LookupRange Is Nothing Then Exit Function
    If LookupColumn < 1 Or LookupColumn > LookupRange.Columns.Count _
      Then Exit Function

    ' Copy values of Lookup Range to Lookup Array.
    LookUpArray = LookupRange

    ' Task: Count the number of values containing LookUp Value
    '       in LookUp Column of LookUp Array which will be
    '       the number of rows in DataToCopy Array.
    '       The number of columns in both arrays will be the same.

    ' Either:
    ' Count the number of values containing LookUp Value.
    countMatch = Application.WorksheetFunction _
      .CountIf(LookupRange.Columns(LookupColumn), LookUpValue)

    ' Although the previous looks more efficient, it should be tested.

'    ' Or:
'    ' Loop through rows of LookUpArray.
'    For r = 1 To UBound(LookUpArray)
'        ' Check if the value in current row in LookUp Column
'        ' is equal to LookUp Value.
'        If LookUpArray(r, LookupColumn) = LookUpValue Then
'            ' Increase DataCopy Rows Counter.
'            countMatch = countMatch + 1
'        End If
'    Next r

    ' Check if no match was found.
    If countMatch = 0 Then Exit Function

    ' Task: Write the matching rows in LookUp Array to DataToCopy Array.

    ' Resize DataToCopy Array to DataToCopy Rows counted in the previous
    ' For Next loop and the number of columns in Lookup Array.
    ReDim DataToCopy(1 To countMatch, 1 To UBound(LookUpArray, 2))
    ' Reset DataToCopy Rows Counter.
    countMatch = 0
    ' Loop through rows of LookUp Array.
    For r = 1 To UBound(LookUpArray)
        ' Check if the value in current row in LookUp Column
        ' is equal to LookUp Value.
        If LookUpArray(r, LookupColumn) = LookUpValue Then
            ' Increase DataCopy Rows Counter.
            countMatch = countMatch + 1
            ' Loop through columns of LookUp (DataToCopy) Array.
            For c = 1 To UBound(LookUpArray, 2)
                ' Write the current value of LookUp Array to DataToCopy Array.
                DataToCopy(countMatch, c) = LookUpArray(r, c)
            Next c
        End If
    Next r

    ' Write values from DataToCopy Array to RangeLookup Array.
    RangeLookup = DataToCopy

End Function
'END ********************************************************************** END'

You should use it e.g. like this:

Sub TryRangeLookup()

    Dim LookupRange As Range
    Dim DataToCopy As Variant

    With MySheet
    'MyRange is a defined name that reprensent column A, B, C, D, E, F
        Set LookupRange = .Range(.Range("MyRange")(1, 1), _
          .Range("MyRange")(8, 6)).Value2
    End With
    RangeLookUp 10073, DataCopy   
    If Not IsArray(DataToCopy) Then 
        MsgBox "No data found.": Exit Sub ' or whatever...
    Endif
    ' Continue with code...

End Sub