动态维度/填充二维数组答案

【问题标题】：Dynamically dimension/populate a 2D array动态维度/填充二维数组
【发布时间】：2016-08-07 17:38:35
【问题描述】：

我有一个有趣的问题。我需要用数据填充二维数组，但在填充数组之前我不知道有多少数据点。

Dim finalArray(0 to 500000, 0 to 3)
R=0

For Each index in someDictionary
    If Not someDictionary.item(index)(1) = 0
        finalArray(R,0) = someDictionary.item(index)(1)
        finalArray(R,1) = someDictionary.item(index)(2)
        finalArray(R,2) = someDictionary.item(index)(3)
        R = R + 1
    End If
Next index

问题是我不知道字典中有多少项，也不知道有多少项是非零的。我知道的唯一方法是在我运行循环并计数 R 之后。

目前我正在将整个 500k 行数组打印到 Excel，这通常是 100-400k 行数据，其余为空白。这很笨拙，我想将数组重新调整为正确的大小。我不能使用ReDim，因为我不能删除数据，也不能使用ReDim Preserve，因为它是二维的，我需要减少行，而不是列。

【问题讨论】：

以对数据进行两次传递为代价，您可以拥有一个集合集合（每行 1 个集合），然后将其转换为单个二维数组。集合在很多方面都是 VBA 中最灵活的数据结构。
如何将信息传递给正确大小的新数组，然后转储旧数组？
为什么不切换数组中行和列的位置，然后您就可以重新调整行了。
@Forward Ed 恐怕这需要遍历旧数组中的每个项目，这对于这么多数据来说可能代价高昂。有没有办法直接赋值？
@INOPIAE 这是一个有趣的想法。我可以试一试。在我打印之前有没有一种有效的方法来转置数组？

标签： arrays vba excel

【解决方案1】：

这个怎么样？

Sub Sample()
    Dim finalArray()
    Dim R As Long

    For Each Index In someDictionary
        If Not someDictionary.Item(Index)(1) = 0 Then R = R + 1
    Next Index

    ReDim finalArray(0 To R, 0 To 3)

    R = 0

    For Each Index In someDictionary
        If Not someDictionary.Item(Index)(1) = 0 Then
            finalArray(R, 0) = someDictionary.Item(Index)(1)
            finalArray(R, 1) = someDictionary.Item(Index)(2)
            finalArray(R, 2) = someDictionary.Item(Index)(3)
            R = R + 1
        End If
    Next Index
End Sub

【讨论】：

【解决方案2】：

你有几个选择

根据需要重新调整数组，而不是预先创建（我认为这比在数组中循环两次 :) 更好）。鉴于您对 tigeravatar 的评论，我已将其添加
转置数组以重新调整第一个维度
根据 tigeravatar 忽略冗余数据

选项 1

请注意，我已经翻转了数据，以便在您进行时围绕 ReDim 进行测试，而不是预先定义数组大小 - 这很可能会改变问题的性质，但我认为该技术值得指出出去。 Option2 展示了如何转置数组

Sub SloaneDog()
    Dim finalArray()
    Dim R As Long
    Dim lngCnt As Long
    Dim lngCnt2 As Long

    lngCnt = 100
    ReDim finalArray(1 To 3, 1 To lngCnt)

    somedictionary = Range("A1:C3001")

    For lngCnt2 = 1 To UBound(somedictionary, 1)
           finalArray(1, lngCnt2) = "data " & lngCnt2
           If lngCnt2 Mod lngCnt = 0 Then ReDim Preserve finalArray(1 To 3, 1 To lngCnt2 + lngCnt)
    Next

End Sub

选项 2

Sub EddieBetts()
Dim X()
Dim Y()
Dim LngCnt As Long

ReDim X(1 To 1000, 1 To 3)
Debug.Print UBound(X, 1)

LngCnt = 100

Y = Application.Transpose(X)
ReDim Preserve Y(1 To UBound(Y, 1), 1 To LngCnt)
X = Application.Transpose(Y)
Debug.Print UBound(X, 1)

End Sub

【讨论】：