ReDim Preserve with multidimensional array in Excel VBA

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