excel – Create Dynamic Array on Criteria and Paste to Worksheet

The source workbook has a worksheet that has 32 columns, and the number rows are dynamic. There will be a column with a value of “Y” or “N”. For each “Y” I need to write that row into an array, even the null cells. The columns header starts are cell “A6” and the details on “A7”.

Next to paste the array into an actual table in a different worksheet. This will happen periodically, and the values will need to be replaced in the table when the user updates the source.

1. Create array from source
2. Clear table in destination worksheet
3. Paste array in table in destination worksheet

Problem is I’m getting no values in the array, and I’m still trying to grasp arrays in general, so any help will be appreciated. The code below is from a small range I was working on for testing purposes.

    Sub CopyToDataset()


    Dim datasetWs As Worksheet
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim cell As Range, rng1 As Range, rng2 As Range, row As Range
    Dim ArrayofAJobs() As Variant
    Dim ArrayofACCJobs() As Variant
    Dim myData As Range
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim LastRowWs1 As Long
    Dim LastRowWs2 As Long

    Set ws1 = ThisWorkbook.Worksheets("Src")
     ' Find the last row with data.
    LastRowWs1 = LastRow(ws1)


    k = 1
    With ws1
    ReDim ArrayofAJobs(6, k)
    For i = 2 To LastRowWs1
    If UCase(Cells(i, 1)) = "Y" Then
        For j = 2 To 4
            If IsNull(ArrayofAJobs(j, k)) Then ArrayofAJobs(j, k) = vbNullString
            ArrayofAJobs(j, k) = Cells(i, j).Value
        Next j
        k = k + 1
        ReDim Preserve ArrayofAJobs(4, k)
    End If
    Next i
    End With


    ArrayofAJobs() = TransposeArray(ArrayofAJobs)

    With ThisWorkbook.Worksheets("Dest")
        .Range("A6") = ArrayofAJobs()
    End With
End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).row
    On Error GoTo 0
End Function


Public Function TransposeArray(myarray As Variant) As Variant
Dim X As Long
Dim Y As Long
Dim Xupper As Long
Dim Yupper As Long
Dim tempArray As Variant
    Xupper = UBound(myarray, 2)
    Yupper = UBound(myarray, 1)
    ReDim tempArray(Xupper, Yupper)
    For X = 0 To Xupper
        For Y = 0 To Yupper
            tempArray(X, Y) = myarray(Y, X)
        Next Y
    Next X
    TransposeArray = tempArray
End Function

===================================================================

Version 2: I’m getting the runtime error 9: subscript out of range.

Sample Source:

Option Explicit
Option Base 1

Sub CopyToDataset()

 Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim destWkb As Workbook
    Dim cell As Range, rng1 As Range, rng2 As Range, row As Range
    Dim ArrayofAJobs() As Variant
    Dim ArrayofACCJobs() As Variant
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim LastRowWs1 As Long
    Dim LastRowWs2 As Long
    k = 1
    Const startRow As Long = 6


    Set ws1 = ThisWorkbook.Worksheets("Src")

     ' Find the last row with data on ws1.
    LastRowWs1 = LastRow(ws1)
    Debug.Print LastRowWs1


    With ws1
    ReDim ArrayofAJobs(i, 32)
    For i = 1 + startRow To LastRowWs1 'Number of rows starting at row 6. Details start on row 7.
    If UCase(.Cells(i, 1)) = "Y" Then
        For j = 1 To 32 'Number of columns starting on column A
            If IsNull(ArrayofAJobs(i, j)) Then ArrayofAJobs(i, j) = vbNullString
            ArrayofAJobs(i, j) = .Cells(i, j).Value
        Next j
    End If
    Next i
    End With

    With ThisWorkbook.Worksheets("Dest")
        .Range(.Cells(2, 1), .Cells(UBound(ArrayofAJobs, 1), UBound(ArrayofAJobs, 2))) = ArrayofAJobs()
    End With
End Sub

Tags: arraysexcel, dynamic