问题
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.
回答1:
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
回答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:
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.
回答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
having said that I can think of 2 options
Option 1
Store the results in a new temp sheet
Option 2
Declare a 1D array and then concatenate your results using a unique delimiter for example "#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)
来源：https://stackoverflow.com/questions/11978184/use-findnext-to-fill-multidimensional-array-vba-excel