使用findnext填充多维数组VBA Excel

Question

我的问题实际上涉及EXCEL VBA Store search results in an array? 上的一个问题

在这里，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

重新调整循环中的数组似乎出错了。我得到一个下标超出范围错误。我想我不能像现在这样重新调整数组，但我不知道应该怎么做。

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

Answer 1

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

来自以上链接：

保留

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

编辑： 这不是很有帮助，是吗。我建议你转置你的数组。此外，这些来自数组函数的错误消息是 AWFUL。

在 Siddarth 的建议下，试试这个。如果您有任何问题，请告诉我：

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

Answer 2

这是一个假设您可以在开始时对数组进行标注的选项。我在 UsedRange 上使用了 WorsheetFunction.Countif 作为“字符串”，这似乎应该可以工作：

Option Explicit

    Sub fillArray()

    Dim i As Long
    Dim aCell As Range, bCell As Range
    Dim arr() As Variant
    Dim SheetToSearch As Excel.Worksheet
    Dim StringCount As Long

    Set SheetToSearch = ThisWorkbook.Worksheets("log")
    i = 1

    With SheetToSearch
        StringCount = Application.WorksheetFunction.CountIf(.Cells, "string")
        ReDim Preserve arr(1 To StringCount, 1 To 6)
        Set aCell = .UsedRange.Find(What:=("string"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

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

            Do Until i > StringCount
                Set bCell = .UsedRange.FindNext(after:=bCell)
                If Not bCell Is Nothing Then
                    arr(i, 1) = True    'Boolean
                    arr(i, 2) = bCell.Value    'String
                    arr(i, 3) = bCell.Cells.Offset(0, 1).Value
                    arr(i, 4) = bCell.Cells.Offset(0, 3).Value
                    arr(i, 5) = bCell.Cells.Offset(0, 4).Value
                    arr(i, 6) = Year(bCell.Cells.Offset(0, 3).Value)
                    i = i + 1
                End If
            Loop
        End If
    End With

    End Sub

请注意，我修复了您声明中的一些问题。我添加了 Option Explicit，它强制您声明变量 - exitLoop 未声明。现在 aCell 和 bCell 都是范围 - previously only bCell was（向下滚动到“注意用一个昏暗语句声明的变量”）。我还创建了一个工作表变量，并将其括在 With 语句中。另外，我将数组的两个维度都从 1 开始，因为......好吧，因为我想我猜 :)。我还简化了一些循环退出逻辑 - 我认为您不需要所有这些来判断何时退出。

Answer 3

你不能Redim Preserve 像这样的多维数组。在多维数组中，使用 Preserve 时只能更改最后一个维度。如果您尝试更改任何其他维度，则会发生运行时错误。我建议阅读此msdn 链接

说了我能想到2个选项

选项 1

将结果存储在新的临时表中

选项 2

声明一维数组，然后使用唯一的分隔符连接您的结果，例如 "#Evert_Van_Steen#"

在代码的顶部

Const Delim As String = "#Evert_Van_Steen#"

那就这样用吧

ReDim Preserve arr(i)

arr(i) = True & Delim & aCell.Value & Delim & aCell.Cells.Offset(0, 1).Value & Delim & _
aCell.Cells.Offset(0, 3).Value & Delim & aCell.Cells.Offset(0, 4).Value & Delim & _
Year(aCell.Cells.Offset(0, 3).Value)