VBA 循环将行添加到被错误覆盖的数组？

Question

我一直在研究一个 sub 并且在同一个问题上停留了一会儿，希望有人有一个简单的解决方案！

我有一个按站名排列的行数据，（每个站 6 行（月）左右）简单地说，我想为每个站名，将适当的数据行提取到变量中/（数组？）稍后用 "back end" 进行一些计算。

我目前的代码是：

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

所以对我来说，这看起来像是一个嵌套的 for 循环（对于每个站点，对于每条线路），只取一个站点，我遍历 "Electrical Checks" sheet 以找到包含的行站名，"extract" 匹配的相应行，当找到新行时，我尝试使用转置和 ReDim Preserve 将新的转置行添加到 ElectricalData 数组 - 这给出了一个二维数组有 20 行和 6 列（每月一列），

然而，我在 i 的每次迭代中发现，数据提取得很好，但一直覆盖第一列而不是将其保存在数组中，例如，如下所示： incorrectly saved data

其中0.310018值肯定是最后一个月的参数。当我通过脚本按 F8 键时，ElectricalData 中的列数增加 1，但数据始终保存在第一列中，而不是继续移动。如果有人知道为什么空列保持为空（我是否错误地使用了 ReDim Preserve？），我将非常感激！

非常感谢， C

Answer 1

像这样：

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 循环将行添加到被错误覆盖的数组？

VBA loop to add rows to array being incorrectly overwritten?

arrays

excel

vba

loops

overwrite