ReDim array inside nested loops

Hi All,

On sheet1 I have a data table with a fixed number of columns and a variable number of rows. I'd like to write a script that runs through column A and adds all the values from that row to an array. I keep getting an error on my ReDim step. Hoping one of you has a solution!

Thanks in advance!

Alex

Sub ArrayTesting()
Dim MyArray() As Variant
Dim NumCols As Integer
Dim NumRows As Integer
Dim i As Integer
Dim j As Integer
Dim cell As Range

NumCols = 3
NumRows = Cells(Rows.Count, 1).End(xlUp).Row

ReDim MyArray(1 To NumRows, 1 To NumCols)

i = 1
For Each cell In Worksheets("Sheet1").Range("A1:A" & NumRows).Cells
    If cell.Value = "A1" Then
        ReDim Preserve MyArray(1 To i, 1 To NumCols)
            For j = 1 To NumCols
                MyArray(i, j) = Cells(i, j).Value
            Next j
    End If
    i = i + 1
Next cell

'print results
For i = 1 To NumRows
    For j = 1 To NumCols
        Debug.Print MyArray(i, j)
    Next j
Next i

End Sub

Just noticed I left out a piece of what I'm trying to do! I want to be able to look through column A and add values from that row to an array IF the value in column A meets certain criteria. Sorry for the omission!

I narrowed the problem down a bit. It returns an error when the array has only 1 row. Error is on the line where I try to print results

Thank you for all the help everyone! Conceptualizing the transpose is a little weird, but I think I get it now. I amended Norie's code slightly and keep getting a "subscript out of range" error.

Sub ArrayTesting()
Dim cell As Range
Dim MyArray() As Variant
Dim NumCols As Long
Dim NumRows As Long
Dim i As Long
Dim j As Long
Dim cnt As Long
Dim SearchFor As String

SearchFor = "A4"

    NumCols = 4
    NumRows = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

    For Each cell In Worksheets("Sheet1").Range("A1:A" & NumRows).Cells
        If cell.Value = SearchFor Then
            cnt = cnt + 1
            ReDim Preserve MyArray(1 To NumCols, 1 To cnt)
            For j = 1 To NumCols
                MyArray(j, cnt) = Cells(cell.Row, j).Value
            Next j
        End If
        
    Next cell

    MyArray = Application.Transpose(MyArray)
    
    'print results
    For i = 1 To cnt
        For j = 1 To NumCols
            Worksheets("Sheet2").Cells(i, j) = MyArray(i, j)
        Next j
    Next i

End Sub

Ahh good call, xlnitwit. Here's my final code. Seems to be working well for anyone else who has this problem. Thanks to everyone who helped me out!

Sub ArrayTesting()
Dim cell As Range
Dim MyArray() As Variant
Dim NumCols As Long
Dim NumRows As Long
Dim i As Long
Dim j As Long
Dim cnt As Long
Dim SearchFor As String

SearchFor = "A4"

NumCols = 4
NumRows = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

For Each cell In Worksheets("Sheet1").Range("A1:A" & NumRows).Cells
    If cell.Value = SearchFor Then
        cnt = cnt + 1
        ReDim Preserve MyArray(1 To NumCols, 1 To cnt)
        For j = 1 To NumCols
            MyArray(j, cnt) = Cells(cell.Row, j).Value
        Next j
    End If
Next cell

MyArray = Application.Transpose(MyArray)


'print results
'if cnt = 1 then transposing array makes it _
a 1D array, not a 2D array

If cnt = 1 Then
    For j = 1 To NumCols
        Debug.Print MyArray(j)
    Next j
    
Else

For i = 1 To cnt
    For j = 1 To NumCols
        Debug.Print MyArray(i, j)
    Next j
Next i
End If

End Sub

Sorry to keep coming back, but as I incorporate Norie's code into my larger code, I keep running into problems. Now I'm getting an error on the transpose step after I put it inside another loop. Anyone have a way around this?

Sub ArrayTesting()
Dim cell As Range
Dim MyArray() As Variant
Dim NumCols As Long
Dim NumRows As Long
Dim i As Long
Dim j As Long
Dim cnt As Long
Dim sDate As String
Dim RefType As String
Dim DeviceCategory As String
Dim Headline As String
Dim p As Long
Dim iRow As Long

Application.ScreenUpdating = False
Application.EnableEvents = False

'clear output range
Worksheets("Sheet2").UsedRange.ClearContents

Set DataWS = Worksheets("data")
Set OutputWS = Worksheets("Sheet4")

sDate = "10/6/2016"
RefType = "Referral"
DeviceCategory = "total"
NumCols = 17
NumRows = DataWS.Cells(Rows.Count, 1).End(xlUp).Row

LastTableRow = OutputWS.Cells(Rows.Count, 1).End(xlUp).Row

For iRow = LastTableRow To 2 Step -1
    Headline = OutputWS.Cells(iRow, 2).Value

'populate array
    For Each cell In DataWS.Range("A1:A" & NumRows).Cells
        If cell.Value = sDate Then
            If DataWS.Cells(cell.Row, "B").Value = RefType Then
                If DataWS.Cells(cell.Row, "F").Value = DeviceCategory Then
                    If DataWS.Cells(cell.Row, "E").Value = Headline Then
                        If DataWS.Cells(cell.Row, "C").Value <> "." Then
            
                            cnt = cnt + 1
                            ReDim Preserve MyArray(1 To NumCols, 1 To cnt)
                            For j = 1 To NumCols
                                MyArray(j, cnt) = DataWS.Cells(cell.Row, j).Value
                            Next j
                            
                        End If
                    End If
                End If
            End If
        End If
    Next cell

    MyArray = Application.Transpose(MyArray)

MsgBox UBound(MyArray)

Next iRow

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub