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

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