使用findnext填充多维数组VBA Excel

My question actually concerns a matter that extends on EXCEL VBA Store search results in an array?

我的问题实际上是关于EXCEL VBA商店搜索结果在数组中扩展的问题？

Here Andreas tried to search through a column and save hits to an array. I am trying the same. But differing in that on (1) finding a value (2) I want to copy different value types from (3) cells in the same row as where the searched value was found, (4) to a two dimensional array.

Andreas试图在列中搜索并将命中保存到数组中。我也在尝试。但不同之处在于（1）找到值（2）我想从（3）单元格中找到与搜索到的值相同的行中的不同值类型，（4）到二维数组。

So the array would (conceptually) look something like:

因此，数组（概念上）看起来像：

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.

The code I use looks like this:

我使用的代码如下所示：

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

It seems to go wrong on redimming the array in the loop. I get a Subscript out of range error. I guess I can't redim the array as I'm doing now, but I can't figure out how it is supposed to be done.

在循环中重新调整数组似乎出错了。我得到一个下标范围错误。我想我现在无法重新调整数组，但我无法弄清楚它应该如何完成。

I’d be greatful for any clues as to what I’m doing wrong.

对于我做错的任何线索，我都会很高兴。

3 个解决方案

#1

ReDim Preserve can only resize the last dimension of your array: http://msdn.microsoft.com/en-us/library/w8k3cys2(v=vs.71).aspx

ReDim Preserve只能调整阵列的最后一个维度：http：//msdn.microsoft.com/en-us/library/w8k3cys2（v = vs.71）.aspx

From the above link:

从以上链接：

Preserve

保留

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

可选的。用于在仅更改最后一个维度的大小时保留现有数组中的数据的关键字。

Edit: That's not enormously helpful, is it. I suggest you transpose your array. Also, those error messages from the array functions are AWFUL.

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

At the suggestion of Siddarth, try this. Let me know if you have any problems:

根据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

Note: in the declarations, you had:

注意：在声明中，您有：

Dim aCell, bCell as Range

Which is the same as:

这与：

Dim aCell as Variant, bCell as Range

Some test code to demonstrate the above:

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

Sub testTypes()

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

End Sub

#2

Here's an option that assumes you can dimension the array at the beginning. I used a WorsheetFunction.Countif on the UsedRange for "string," which seems like it should work:

这是一个选项，假设您可以在开头标注数组。我在UsedRange上使用WorsheetFunction.Countif获取“string”，看起来它应该可以工作：

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

Note that I fixed some issues in your declarations. I added Option Explicit, which forces you to declare your variables - exitLoop was undeclared. Now both aCell and bCell are ranges - previously only bCell was (scroll down to "Pay Attention To Variables Declared With One Dim Statement"). I also created a worksheet variable and surrounded it in a With statement. Also, I started both dimensions of the array at 1 because... well because I wanted to I guess :). I also simplified some of the loop exiting logic - I don't think you needed all that to tell when to exit.

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

#3

You cannot Redim Preserve a multi dimensional array like this. In a multidimensional array, you can change only the last dimension when you use Preserve. If you attempt to change any of the other dimensions, a run-time error occurs. I would recommend reading this msdn link

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

having said that I can think of 2 options

说过我可以想到2个选项

Option 1

选项1

Store the results in a new temp sheet

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

Option 2

选项2

Declare a 1D array and then concatenate your results using a unique delimiter for example "#Evert_Van_Steen#"

声明一维数组，然后使用唯一分隔符连接结果，例如“＃Evert_Van_Steen＃”

At the top of the code

在代码的顶部

Const Delim As String = "#Evert_Van_Steen#"

Then use it like this

然后像这样使用它

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)

#1