Excel VBA - Writing data to Array doesn't work

Question

Today I started studying Arrays in VBA.

After trying a few easy scripts I wanted to create one that is useful for my project.

In my excelsheet I have a datatable that needs to be transformed to new worksheets. Only for each column that has "Detail" in row 4.

The easiest way to imagine this would be by writing the values per relevant column to an array, reading and writing the results to a new sheet, and performing the action again.

But I think I'm using a wrong method to write the variables to my array. I looked through my code and all my declarions are not correct.

Could you help me out, how I can change the writing to the array correct?

Sub Import_data()

Dim LastCol As Integer
Dim LastRow As Long
Dim WS As Worksheet
Dim Arr() As Variant
Dim dim1 As Long, dim2 As Long

Set WS = Sheets("Budget to Table")



' Copy data from Budget to Table
    With WS
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        dim1 = .Cells(.Rows.Count, "B").End(xlUp).Row - 5
        dim2 = 4

    ' Copy information
        For i = 3 To LastCol
            If Cells(4, i).Value = "Detail" Then

                ReDim Arr(0 To dim1, 0 To dim2)

                    For dim1 = LBound(Arr, 1) To UBound(Arr, 1)
                        For dim2 = LBound(Arr, 2) To UBound(Arr, 2)
                            Arr(dim1, 0) = Range(Cells(dim1, 2)) 'Should have the variable length but always column B
                            Arr(dim1, 1) = Range(Cells(dim1, i)) 'Should have the variable length but always column i
                            Arr(dim1, 2) = Range(Cells(1, i)) 'Is always the same header info from row 1 of the chosen column
                            Arr(dim1, 3) = Range(Cells(2, i)) 'Is always the same header info from row 2 of the chosen column
                            Arr(dim1, 4) = Range(Cells(3, i)) 'Is always the same header info from row 3 of the chosen column
                        Next dim2
                    Next dim1

            End If

            'writing the contents in a new sheet
            Worksheet.Add
                For dim1 = LBound(Arr, 1) To UBound(Arr, 1)
                    For dim2 = LBound(Arr, 2) To UBound(Arr, 2)
                        ActiveCell.Offset(dim1, dim2).Value = Arr(dim1, dim2)
                    Next dim2
                Next dim1
            Erase Arr
        Next i
    End With

End Sub

If I need to provide any more guidance please let me know. I guess that the value of the dim1 and dim2 are never changing, so this doesn't create the loop i'm after.

edit: I uploaded the file here: https://dubblej15.stackstorage.com/s/C0DrKzFDxn4gY4U

I manually performed the action twice, what my result should look like. Maybe there is a better or easier way, but I thought that arrays could fit the job perfectly.

Thanks in advance!

Ambie · Accepted Answer

There are a few issues with your code (do watch out for those unqualified Ranges), but the main one is that you're getting your array indexes mixed up with the cell row and column references, and as you point out, there are a few pieces of redundant code where you dimension your array. Redim Preserve is also limited when you use multi-dimensional arrays.

So, immediately below is a modified version of your code which shows the required adjustments.

However, if you want to work with arrays, then you can be much more efficient. For example, you can read ranges into arrays and write from arrays to ranges in just one line of code (which is way faster than using loops). The second piece of code shows you a more efficient way of handling the task - I wasn't sure if your sample rows will all have "Details' in column "A", because if they do without interruption, then the code could be even shorter.

Your modified code:

Dim dataWs As Worksheet, newWs As Worksheet
Dim lastRow As Long, lastCol As Long
Dim c As Long, r As Long, i As Long, j As Long
Dim arr() As Variant

'Read the data into an array
Set dataWs = ThisWorkbook.Worksheets("Budget to Table")
With dataWs
    lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With

'Loop through each of the data columns.
For c = 3 To lastCol
    If Not IsEmpty(dataWs.Cells(3, c)) Then 'looks lik you only want the yellow columns.
        'Dimension the array for number of rows
        ReDim arr(1 To lastRow - 4, 1 To 5)
        'Loop through each row in data array and transfer it.
        With dataWs
            For r = 5 To lastRow
                arr(r - 4, 1) = .Cells(r, 2).Value
                arr(r - 4, 2) = .Cells(r, c).Value
                arr(r - 4, 3) = .Cells(1, c).Value
                arr(r - 4, 4) = .Cells(2, c).Value
                arr(r - 4, 5) = .Cells(3, c).Value
            Next
        End With
        'Create a new sheet.
        With ThisWorkbook.Worksheets
            Set newWs = .Add(After:=.Item(.Count))
            newWs.Name = arr(1, 5) 'name it for ease of use.
        End With
        'Write array onto the new sheet - the inefficient way
        For i = 1 To UBound(arr, 1)
            For j = 1 To UBound(arr, 2)
                newWs.Cells(i, j).Value = arr(i, j)
            Next
        Next
    End If
Next

A different way of handling arrays:

Dim ws As Worksheet
Dim data As Variant, output() As Variant
Dim rowList As Collection
Dim c As Long, i As Long
Dim r As Variant

'Read the data into an array
With ThisWorkbook.Worksheets("Budget to Table")
    data = .Range(.Range("A1"), _
           .Range(.Cells(1, .Columns.Count).End(xlToLeft), _
                  .Cells(.Rows.Count, "B").End(xlUp))) _
           .Value2
End With

'Find the first dimension indexes with "Detail" in column A.
'We'll create a collection of our target row numbers.
Set rowList = New Collection
For i = 1 To UBound(data, 1)
    If data(i, 1) = "Detail" Then rowList.Add i
Next

'Loop through each of the data columns.
For c = 3 To UBound(data, 2)
    If Not IsEmpty(data(3, c)) Then 'looks lik you only want the yellow columns.
        'Dimension the array for number of rows
        ReDim output(1 To rowList.Count, 1 To 5)
        i = 1 'row index for output array
        'Loop through each row in data array and transfer it.
        For Each r In rowList
            output(i, 1) = data(r, 2)
            output(i, 2) = data(r, c)
            output(i, 3) = data(1, c)
            output(i, 4) = data(2, c)
            output(i, 5) = data(3, c)
            i = i + 1
        Next
        'Create a new sheet.
        With ThisWorkbook.Worksheets
            Set ws = .Add(After:=.Item(.Count))
            ws.Name = output(1, 5) 'name it for ease of use.
        End With
        'Write array onto the new sheet.
        ws.Range("A1").Resize(UBound(output, 1), UBound(output, 2)).Value = output
    End If
Next

Excel VBA - Writing data to Array doesn't work

Answers (2)

Related Questions

Excel VBA - Writing data to Array doesn&#39;t work

Answers (2)

Related Questions

Excel VBA - Writing data to Array doesn't work