使用FindNext函数填充多维数组VBA Excel。

Question

使用FindNext函数填充多维数组VBA Excel。

3

我的问题实际上涉及到一个扩展的问题，即如何在 EXCEL VBA中将搜索结果存储在数组中？在这里，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

似乎在循环中重新调整数组大小出了问题。我收到了一个下标超出范围的错误。我猜我不能像现在这样重新定义数组大小，但我想不出应该如何完成它。

如果有任何线索可以告诉我我做错了什么，我将不胜感激。

- Evert Van Steen

3个回答

3

这里有一个选项，假设你可以在开始时定义数组的维度。我在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

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

- Doug Glancy

2

您不能这样使用Redim Preserve来调整多维数组。在多维数组中，只有最后一个维度可以使用Preserve关键字更改大小。如果您尝试更改任何其他维度，则会发生运行时错误。建议阅读此msdn链接。

话虽如此，我能想到两个选项： 选项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)

- Siddharth Rout

看起来 OP 目前有一个固定的第二维，他可以转置数组，这样他就可以重新调整第二维了。 - mkingston

是的，他可以做到，但对于新手来说，这可能真的很痛苦。 - Siddharth Rout

既然您首先提到了它，我建议在您的帖子中添加一个示例，来说明如何实现 :) - Siddharth Rout

我说到做到，但被道格抢先了！哈哈！ - mkingston

我提供的第二个选项比转置数组更容易理解。但是如果你能理解如何转置数组，那就再好不过了 ;) - Siddharth Rout

显示剩余3条评论

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- mkingston · Accepted Answer

ReDim Preserve 只能调整数组的最后一个维度大小: http://msdn.microsoft.com/en-us/library/w8k3cys2(v=vs.71).aspx 从上面的链接中: Preserve 可选。当您仅更改最后一个维度的大小时，用于保留现有数组中的数据的关键字。 编辑: 那并不是非常有帮助。我建议你转置数组。另外，那些来自数组函数的错误消息真的很糟糕。

在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