ReDim Preserve with multidimensional array in Excel VBA - arrays

Question

I can get this to work but am not sure if this is the correct or the most efficient way of doing this.
Details: Looping through 151 rows then assigning column A and B only of those rows to a two dimensional array based on criteria in column C. With the criteria only 114 of the 151 rows are needed in the array.
I know that with ReDim Preserve you can only resize the last array dimension and you can't change the number of dimensions at all. So I have sized the rows in the array to be the total 151 rows using the LRow variable but the actual rows I only need in the array is in variable ValidRow so it seems that (151-114) = 37 superfluous rows are in the array as a result of the ReDim Preserve line. I would like to make the array only as big as it needs to be which is 114 rows not 151 but not sure if this is possible see code below and any help much appreciated as I am new to arrays and have spent the best part of two days looking at this. Note: Columns are a constant no issue with them but rows vary.
Sub FillArray2()
Dim Data() As Variant
Dim ValidRow, r, LRow As Integer
Sheets("Contract_BR_CONMaster").Select
LRow = Range("A1").End(xlDown).Row '151 total rows
Erase Data()
For r = 2 To LRow
If Cells(r, 3).Value <> "Bridge From" And Cells(r, 3).Value <> "Bridge To" Then
ValidRow = ValidRow + 1
ReDim Preserve Data(1 To LRow, 1 To 2)
Data(ValidRow, 1) = Range("A" & r).Value 'fills the array with col A
Data(ValidRow, 2) = Range("B" & r).Value 'fills the array with col B
End If
Next r
ActiveWorkbook.Worksheets("Test").Range("A2:B" & ValidRow + 1) = Data() 'assign after loop has run through all data and assessed it
End Sub

Answer 1

I seemed to have got this to work by using transposition where the rows and cols are swapped around and still using ReDim Preserve then transposing at the end when assigning to a range. This way the array is exactly the size it needs to be with no blank cells.
Sub FillArray3() 'Option 3 works using transposition where row and cols are swapped then swapped back at the end upon assignment to the range with no blank cells as array is sized incrementally via the For/Next loop
Dim Data() As Variant
Dim ValidRow, r, LRow As Integer
Sheets("Contract_BR_CONMaster").Select
LRow = Range("A1").End(xlDown).Row '151 total rows
Erase Data()
For r = 2 To LRow
If Cells(r, 3).Value <> "Bridge From" And Cells(r, 3).Value <> "Bridge To" Then
ValidRow = ValidRow + 1
ReDim Preserve Data(1 To 2, 1 To ValidRow) 'can change the size of only the last dimension if you use Preserve so swapped rows and cols around
Data(1, ValidRow) = Range("A" & r).Value 'fills the array with col A
Data(2, ValidRow) = Range("B" & r).Value 'fills the array with col B
End If
Next r
ActiveWorkbook.Worksheets("Test").Range("A2:B" & ValidRow + 1) = Application.Transpose(Data) 'swap rows and cols back
End Sub

Answer 2

Note also that the internal VBA implementation of REDIM is not guaranteeing to release the storage when it is sized down. It would be a common choice in such an implementation to not physically reduce the storage until the size dropped to less than half the input size.
Have you considered creating a type-safe collection class to store this information instead of an array? In it's most basic form (for a storage type of Integer) it would look be a Class Module like this:
Option Explicit
Private mData As Collection
Public Sub Add(Key As String, Data As Integer)
mData.Add Key, Data
End Sub
Public Property Get Count() As Integer
Count = mData.Count
End Property
Public Function Item(Index As Variant) As Integer
Item = mData.Item(Index)
End Function
Public Sub Remove(Item As Integer)
mData.Remove Item
End Sub
Private Sub Class_Initialize()
Set mData = New Collection
End Sub
A particular advantage of this implementation is that the sizing logic is completely removed from the client code, as it should be.
Note that the Data type stored by such a patter can be any type supported by VBA, including an Array or another Class.

Answer 3

Two more ways of doing this.
FillArray4 - Initial array is created too large but second part of code moves this to a new array using a double loop which creates the array to be the exact size it needs to be.
Sub FillArray4()
Dim Data() As Variant, Data2() As Variant
Dim ValidRow As Integer, r As Integer, lRow As Integer
Sheets("Contract_BR_CONMaster").Select
lRow = Range("A1").End(xlDown).Row '151 total rows
'Part I - array is bigger than it has to be
Erase Data()
For r = 2 To lRow
If Cells(r, 3).Value <> "Bridge From" And Cells(r, 3).Value <> "Bridge To" Then
ValidRow = ValidRow + 1 'this is the size the array needs to be 114 rows
ReDim Preserve Data(1 To lRow, 1 To 2) 'but makes array to be 151 rows as based on lrow not ValidRow as cannot dynamically resize 1st dim of array when using preserve
Data(ValidRow, 1) = Range("A" & r).Value 'fills the array with col A
Data(ValidRow, 2) = Range("B" & r).Value 'fills the array with col B
End If
Next r
'Part II
'move data from Data() array that is too big to new array Data2() that is perfectly sized as it uses ValidRow instead of lrow
Erase Data2()
For i = LBound(Data, 1) To UBound(Data, 1) 'Rows
For j = LBound(Data, 2) To UBound(Data, 2) 'Cols
If Not IsEmpty(Data(i, j)) Then
ReDim Preserve Data2(1 To ValidRow, 1 To 2)
Data2(i, j) = Data(i, j) 'fills the new array with data from original array but only non blank dims; Data2(i,j) is not one particular row or col its an intersection in the array
'as opposed to part one where you fill the initial array with data from cols A and B using seperate lines for each col
End If
Next
Next
ActiveWorkbook.Worksheets("Test").Range("A2:B" & ValidRow + 1) = Data2() 'assign data from new array to worksheet
End Sub
Sub FillArray5 - Much simpler and my preferred option as you only create one array. Initial loop determines the size the array needs to be and then second loop uses this to create array and store data. Note only two cols in both cases. Issue I had in this scenario was creating 2D array where rows varied. That's it for me time to go to the tropics for a well earned holiday!
Sub FillArray5()
Dim Data() As Variant
Dim ValidRow As Integer, r As Integer, lRow As Integer, DimCount As Integer, RemSpaceInArr As Integer
Sheets("Contract_BR_CONMaster").Select
lRow = Range("A1").End(xlDown).Row
Erase Data()
For r = 2 To lRow
If Cells(r, 3).Value <> "Bridge From" And Cells(r, 3).Value <> "Bridge To" Then
ValidRow = ValidRow + 1 'this is the size the array needs to be 114 rows
End If
Next r
DimCount = 0 'reset
For r = 2 To lRow
If Cells(r, 3).Value <> "Bridge From" And Cells(r, 3).Value <> "Bridge To" Then
ReDim Preserve Data(1 To ValidRow, 1 To 2) 'makes array exact size 114 rows using ValidRow from first loop above
DimCount = DimCount + 1 'need this otherwise ValidRow starts the dim at 114 but needs to start at 1 and increment to max of ValidRow
Data(DimCount, 1) = Range("A" & r).Value 'fills the array with col A
Data(DimCount, 2) = Range("B" & r).Value 'fills the array with col B
End If
Next r
RemSpaceInArr = ValidRow - DimCount 'just a check it should be 0
ActiveWorkbook.Worksheets("Test").Range("A2:B" & ValidRow + 1) = Data() 'assign data from array to worksheet
End Sub