使用findnext填充multidimensional arrayVBA Excel

我的问题实际上涉及一个问题，扩展在EXCEL VBA商店search结果的数组？

在这里，Andreas试图search一列，并将命中保存到一个数组。 我正在尝试相同的。 但不同的是（1）find一个值（2）我想复制不同的值types从（3）单元格在findsearch值的同一行，（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.

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

在Siddarth的build议下，试试这个。 让我知道如果你有任何问题：

 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 

一些testing代码来演示以上内容：

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

Answer 2

这是一个假设您可以在开始时确定数组大小的选项。 我在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，它强制你声明你的variables – exitLoop是未声明的。 现在，aCell和bCell都是范围 – 以前只有bCell是 （向下滚动到“关注variables声明的variables”）。 我还创build了一个工作表variables，并将其包含在With语句中。 此外，我开始在两个维度的数组，因为…以及因为我想我猜:)。 我也简化了一些退出逻辑的循环 – 我不认为你需要所有的告诉什么时候退出。

Answer 3

你不能Redim Preserve的multidimensional array。 在multidimensional array中，当您使用Preserve时，只能更改最后一个维度。 如果您尝试更改任何其他维度，则会发生运行时错误。 我会build议阅读这个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)