Home » excel » excel – Create Dynamic Array on Criteria and Paste to Worksheet

excel – Create Dynamic Array on Criteria and Paste to Worksheet

Posted by: admin May 14, 2020 Leave a comment

Questions:

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.

enter image description here

    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.

enter image description here

Sample Source:

enter image description here

enter image description here

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
How to&Answers:

Without seeing the workbook, I’m not 100% sure I followed you exactly, but I do see a few things that I would change.

  1. You need to add a “.” before Cells. That dot ensures that the cells that you’re picking up are from ws1 and not the active sheet.

    If UCase(.Cells(i, 1)) = "Y" Then    
    
        ArrayofAJobs(j, k) = .Cells(i, j).Value
    
  2. The watch window didn’t have any of the array elements expanded so I we can’t see that the array is actually empty. But, you cannot Redim Preserve the first dimension of an array.

    ReDim ArrayofAJobs(6, k)
    
    ReDim Preserve ArrayofAJobs(4, k)   'This line should cause a Runtime Error 9.
    

    It looks like you need to change the first ReDim to ArrayofAJobs(**4**, k).

  3. When you “paste” an array, you have to specify the entire range that it’s going to be “pasted” to. It’s not like pasting a range of copied cells where you can tell Excel the top, left cell and it figures out the rest. So you would need to change your code from

    .Range("A6") = ArrayofAJobs()
    

    to this.

    .Range(.Cells(6, 1), .Cells(UBound(ArrayofAJobs, 1), UBound(ArrayofAJobs, 2))) = ArrayofAJobs