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
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.
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