VBA loop to add rows to array being incorrectly overwritten?

Question

I've been working on a sub and been stuck on the same issue for a wee while and hoping someone has an easy solution!

I have a data in rows arranged by station names, (6 or so rows(months) per station) and put simply I would like to for each station name, extract the appropriate rows of data into a variable/(array?) to later do some "back end" calculations with.

the code I have so far is:

Sub Electrical_Checks()

Dim a As Integer
Dim i As Integer
Dim ElectricalData As Variant

a = Worksheets("1. Electrical Checks_Yes_No_CFC").Cells(Rows.Count, 1).End(xlUp).Row

' get electrical data per station
For Each Cell In Worksheets("Total Checks").Range("StationNames") 'for each station name in the StationNames dynamic range in Total Checks sheet
c = 0
For i = 1 To a 'if match in Checks sheet, extract row to ElectricalData
    If Worksheets("1. Electrical Checks_Yes_No_CFC").Cells(i, 3) = Cell Then
    c = c + 1
    ElectricalData = Application.Transpose(Worksheets("1. Electrical Checks_Yes_No_CFC").Rows(i).Columns("A:T")) 'transpose to make ReDim Preserve work

    ReDim Preserve ElectricalData(1 To 20, 1 To c) 'add new column

    End If
Next i
Debug.Print ElectricalData 'my inelegant way to bring up an error to check in locals window

Next Cell

End Sub

So to me, this looks like a nested for loop (for each station, for each line), taking just one station, I looped through the "Electrical Checks" sheet to find the rows containing the station name, "extract" the appropriate row where there is match, and as a new row is found I've tried to use transpose and ReDim Preserve to add the new transposed row to the ElectricalData array- this gives a 2D array with 20 rows and 6 columns (a column per month),

However what I find with each iteration of i, is that the data is extracted fine, but keeps overwriting the first column instead of saving it along the array eg as shown: incorrectly saved data

where the 0.310018 value is definitely a parameter of the final month. As I press F8 through the script, the number of columns in ElectricalData increases by 1, but again the data is always saved in the first column rather than moving along. If anyone has ideas why the empty columns stay empty (am I using ReDim Preserve incorrectly?) I'd be really thankful!

Many thanks, C

Each time you hit a matching row you're recreating ElectricalData as a new array, then resizing it (adding one more column per hit). A better approach might be to use Application.Countif() to first determine the number of matching rows, then size your array before entering the loop. — Tim Williams
@TimWilliams I was trying to write a solution to resize the array during the loop - is there really no way to resize and preserve a multidimensional array like this? — dwirony
You can for sure resize and preserve an array (last dimension only for multi-dimensional arrays) - the problem is you're overwriting your array each time though the loop. — Tim Williams

Tim Williams Tim Williams · Accepted Answer · 2018-09-10T20:04:17

Something like this:

Sub Electrical_Checks()

    Dim a As Long
    Dim i As Long

    Dim ElectricalData() As Variant, shtECYN As Worksheet
    Dim d, n As Long, m As Long, Cell, c As Long

    Set shtECYN = Worksheets("1. Electrical Checks_Yes_No_CFC")

    a = shtECYN.Cells(Rows.Count, 1).End(xlUp).Row

    ' get electrical data per station
    'for each station name in the StationNames dynamic range in Total Checks sheet
    For Each Cell In Worksheets("Total Checks").Range("StationNames")

        'how many matching lines?
        n = Application.CountIf(shtECYN.Cells(i, 3).Resize(a, 1), Cell.Value)
        ReDim Preserve ElectricalData(1 To 20, 1 To n) '<<< size the array to match
        c = 0
        For i = 1 To a 'if match in Checks sheet, extract row to ElectricalData
            If shtECYN.Cells(i, 3) = Cell.Value Then
                c = c + 1
                d = shtECYN.Rows(i).Columns("A:T")
                For m = 1 To UBound(d, 2)
                    ElectricalData(m, c) = d(1, m)
                Next m
            End If
        Next i
        'check the array content (for debugging purposes)
        Sheets("test").Range("A1").Resize(20, n).Value = ElectricalData
    Next Cell

End Sub

VBA loop to add rows to array being incorrectly overwritten?

1 Answers