使用findnext填充多维数组VBA Excel

我的问题实际上涉及一个延伸到的问题EXCEL VBA 将搜索结果存储在数组中？ https://stackoverflow.com/questions/11312226/excel-vba-store-search-results-in-an-array?answertab=active#tab-top

在这里，Andreas 尝试搜索一列并将命中结果保存到一个数组中。我也在尝试同样的事情。但不同之处在于（1）查找值（2）我想从（3）与找到搜索值的同一行中的单元格复制不同的值类型，（4）到二维数组。

所以数组（概念上）看起来像：

Searchresult.1st SameRow.Cell1.Value1 SameRow.Cell2.Value2 SameRow.Cell3.Value3
Searchresult.2nd SameRow.Cell1.Value1 SameRow.Cell2.Value2 SameRow.Cell3.Value3
Searchresult.3rd SameRow.Cell1.Value1 SameRow.Cell2.Value2 SameRow.Cell3.Value3

Etc.

我使用的代码如下所示：

Sub fillArray()

Dim i As Integer
Dim aCell, bCell As Range
Dim arr As Variant

i = 0 

Set aCell = Sheets("Log").UsedRange.Find(What:=("string"), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False, _
                    SearchFormat:=False)

If Not aCell Is Nothing Then
    Set bCell = aCell
    ReDim Preserve arr(i, 5)
    arr(i, 0) = True 'Boolean
    arr(i, 1) = aCell.Value 'String
    arr(i, 2) = aCell.Cells.Offset(0, 1).Value 
    arr(i, 3) = aCell.Cells.Offset(0, 3).Value
    arr(i, 4) = aCell.Cells.Offset(0, 4).Value
    arr(i, 5) = Year(aCell.Cells.Offset(0, 3).Value)

    i = i + 1

    Do While exitLoop = False
            Set aCell = Sheets("Log").UsedRange.FindNext(after:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                'ReDim Preserve arrSwUb(i, 5)
                    arr(i, 0) = True
                    arr(i, 1) = aCell.Value
                    arr(i, 2) = aCell.Cells.Offset(0, 1).Value
                    arr(i, 3) = aCell.Cells.Offset(0, 3).Value
                    arr(i, 4) = aCell.Cells.Offset(0, 4).Value
                    arr(i, 5) = Year(aCell.Cells.Offset(0, 3).Value)

                    i = i + 1
            Else
                exitLoop = True
            End If
    Loop


End If

End Sub

在循环中重新调整数组时似乎出错了。我收到下标超出范围错误。我想我无法像现在一样重新调整数组，但我不知道应该如何完成它。

如果有任何关于我做错了什么的线索，我将不胜感激。

ReDim Preserve 只能调整数组最后一个维度的大小：http://msdn.microsoft.com/en-us/library/w8k3cys2(v=vs.71).aspx http://msdn.microsoft.com/en-us/library/w8k3cys2(v=vs.71).aspx

从上面的链接：

Preserve

Optional. Keyword used to preserve the data in the existing array when you change the size of only the last dimension.

Edit:这并没有多大帮助，是吗？我建议你转置你的数组。此外，来自数组函数的那些错误消息也很糟糕。

在悉达斯的建议下，尝试一下这个。如果您有任何问题，请告诉我：

Sub fillArray()
    Dim i As Integer
    Dim aCell As Range, bCell As Range
    Dim arr As Variant

    i = 0
    Set aCell = Sheets("Log").UsedRange.Find(What:=("string"), _
                                             LookIn:=xlValues, _
                                             LookAt:=xlWhole, _
                                             SearchOrder:=xlByRows, _
                                             SearchDirection:=xlNext, _
                                             MatchCase:=False, _
                                             SearchFormat:=False)
    If Not aCell Is Nothing Then
        Set bCell = aCell
        ReDim Preserve arr(0 To 5, 0 To i)
        arr(0, i) = True 'Boolean
        arr(1, i) = aCell.Value 'String
        arr(2, i) = aCell.Cells.Offset(0, 1).Value
        arr(3, i) = aCell.Cells.Offset(0, 3).Value
        arr(4, i) = aCell.Cells.Offset(0, 4).Value
        arr(5, i) = Year(aCell.Cells.Offset(0, 3).Value)
        i = i + 1
        Do While exitLoop = False
            Set aCell = Sheets("Log").UsedRange.FindNext(after:=aCell)
            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                ReDim Preserve arrSwUb(0 To 5, 0 To i)
                arr(0, i) = True
                arr(1, i) = aCell.Value
                arr(2, i) = aCell.Cells.Offset(0, 1).Value
                arr(3, i) = aCell.Cells.Offset(0, 3).Value
                arr(4, i) = aCell.Cells.Offset(0, 4).Value
                arr(5, i) = Year(aCell.Cells.Offset(0, 3).Value)
                i = i + 1
            Else
                exitLoop = True
            End If
        Loop
    End If
End Sub

注意：在声明中，您有：

Dim aCell, bCell as Range

这与以下内容相同：

Dim aCell as Variant, bCell as Range

一些测试代码来演示上述内容：

Sub testTypes()

    Dim a, b As Integer
    Debug.Print VarType(a)
    Debug.Print VarType(b)

End Sub