3

我的问题实际上涉及在EXCEL VBA Store 搜索结果中扩展的问题？

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

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

对于我做错了什么的任何线索，我都会非常感激。

4

3 回答 3

4

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
于 2012-08-15T22:51:50.917 回答
3

这是一个选项，假设您可以在开始时对数组进行标注。我在 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 都是范围 -以前只有 bCell 是（向下滚动到“注意使用 One Dim 语句声明的变量”）。我还创建了一个工作表变量，并将其括在 With 语句中。此外，我将数组的两个维度都从 1 开始，因为......好吧，因为我想我猜 :)。我还简化了一些循环退出逻辑 - 我认为您不需要所有这些来判断何时退出。

于 2012-08-15T23:35:15.020 回答
2

你不能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)
于 2012-08-15T22:52:57.363 回答