使用findnext来填充多维数组VBA Excel [英] Use findnext to fill multidimensional array VBA Excel

问题描述

我的问题实际上涉及一个扩展到 EXCEL VBA在数组中存储搜索结果

这里Andreas试图搜索一列，并将匹配保存到数组中。我也是一样的但是在（1）找到一个值（2）的情况下，不同的是我想从与（3）找到的值相同的行中的（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 
 
等等
  

代码我使用如下所示：

  Sub fillArray（）
 
 Dim i As Integer 
 Dim aCell，bCell As Range 
 Dim arr As Variant 
 
i = 0 
 
设置aCell = Sheets（Log）。UsedRange.Find（What：= string），_ 
 LookIn：= xlValues，_ 
 LookAt：= xlWhole，_ 
 SearchOrder：= xlByRows，_ 
 SearchDirection：= xlNext，_ 
 MatchCase：= False，_ 
 SearchFormat：= False）
 
如果不是aCell是没有，然后
设置bCell = aCell 
 ReDim保存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 
设置aCell = Sheets（Log）。UsedRange.FindNext（after：= aCell）
 
如果不是aCell是没有
如果aCell.Address = bCell.Address然后退出Do 
'ReDim保存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）=年（aCell.Cells.Offset（0，3）.Value）
 
i = i + 1 
 Else 
 exitLoop = True 
 End If 
循环
 
 
如果
 
结束Sub 
  

在循环中修改数组时似乎出错。我得到一个下标超出范围的错误。我想我现在不能重做数组，但是我无法弄清楚它应该如何完成。

对于我做错了什么的线索，我会很棒。

解决方案

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

从以上链接：

保存

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

编辑： strong>
这不是非常有用的，是吗？我建议你转置你的数组。另外，来自数组函数的错误消息是AWFUL。

根据Siddarth的建议，尝试一下。让我知道如果你有任何问题：

  Sub fillArray（）
 Dim i As Integer 
 Dim aCell As Range，bCell As Range 
 Dim arr As Variant 
 
i = 0 
设置aCell = Sheets（Log）UsedRange.Find（what：=（string ）$ _ 
 LookIn：= xlValues，_ 
 LookAt：= xlWhole，_ 
 SearchOrder：= xlByRows，_ 
 SearchDirection：= xlNext，_ 
 MatchCase：=假，_ 
 SearchFormat：= False）
如果不是aCell是没有，然后
设置bCell = aCell 
 ReDim保存arr（0到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 
设置aCell = Sheets（Log）。UsedRange.FindNext（after：= aCell）
如果不是aCell没有，然后
如果aCell.Address = bCell.Address然后退出Do 
 ReDim保留arrSwUb（0到5，0到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作为范围
  

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

  Sub testTypes（）
 
 Dim a，b As Integer 
 Debug.Print VarType（a）
 Debug.Print VarType （b）
 
 End Sub 
  

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

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.

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.

解决方案

ReDim Preserve can only resize the last dimension of your array: 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.

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

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

这篇关于使用findnext来填充多维数组VBA Excel的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！