Need some help on sorting the values into the correct column.
I can't seem to figure out how I would return the array values to the proper column in the table.
For the output into column B "Pipe DN" it should return the first split text from the values in "Line number", and for the "Service" column F it should return the 2nd split text from "Line number".
How would I accomplish this? -
If for "Pipe DN" I use Range("B19", Range("B19").Offset(Dimension1 - 1, 1)).Value = StrArray, it will return me the correct values, but the "Service" code is not written on the correct column.
Sub SplitLinesIntoArray()
Dim LineNumber() As Variant
Dim StrArray() As Variant
Dim Dimension1 As Long, Counter As Long
LineNumber = Range("J19", Range("J19").End(xlDown))
Dimension1 = UBound(LineNumber, 1)
ReDim StrArray(1 To Dimension1, 1 To 2)
For Counter = 1 To Dimension1
'Pipe DN
StrArray(Counter, 1) = Split(LineNumber(Counter, 1), "-")(0)
Range("B19", Range("B19").Offset(Dimension1 - 1, 0)).Value = StrArray
'Service Code
StrArray(Counter, 2) = Split(LineNumber(Counter, 1), "-")(1)
Range("F19", Range("F19").Offset(Dimension1 - 1, 0)).Value = StrArray(Counter, 2)
Next Counter
'Range("B19", Range("B19").Offset(Dimension1 - 1, 1)).Value = StrArray
Erase LineNumber
Erase StrArray
End Sub
Basically you start well by analyzing a 2-dim datafield array and assigning resulting string manipulations (Split()) to it.
Results seem to (1) output correctly as for the first array "column" ("Pipe DN", starting in cell B19),
whereas (2) the second column ("Service", F19) repeats the result of the very last split action for each array "row".
This impression has to be qualified:
ad 1) You are doing unnecessary extra work by assigning the entire StrArray to the entire "Pipe DN" column,
repeating this action with each single row iteration. (Note that the StrArray gets only completely filled with the last loop).
ad 2) Basically you assign again with each iteration, but this time you get only the latest split result and fill the entire "Service" column
with the latest result assigned to StrArray(Counter,2). Eventually all items show the last split result instead of the individual LineNumber splittings.
See this abbreviated example for three example items only to understand what is happening
(this SnapShot shows the table results when code is stopped after the 2nd iteration (i.e. after Counter=2):
Immediate help
Sticking to your initial code, I'd omit
Range("B19", Range("B19").Offset(Dimension1 - 1, 0)).Value = StrArray as well as
Range("F19", Range("F19").Offset(Dimension1 - 1, 0)).Value = StrArray(Counter, 2)
within the For..Next loop, but add the following two code lines thereafter:
Range("B19", Range("B19").Offset(Dimension1 - 1, 0)).Value = Application.Index(StrArray, 0, 1)
Range("F19", Range("F19").Offset(Dimension1 - 1, 0)).Value = Application.Index(StrArray, 0, 2)
in order to slice the StrArray into columns and write each column separately to your cell target.
Further note:
Fully qualify your range references to prevent possibly unwanted results as Excel would take the currently active sheet if not referenced explicitly ... and this need not be the targeted one :-;
Using VBA, it's not necessary in standard office situations to clear (Erase) at the end of a procedure to free memory.
Possible alternative avoiding array slicing
You might profit from the the following code, which
fully qualifies your range references (note: unqualified refs invite Excel to take the currently active sheet without request),
uses a jagged array (aka as Array of Arrays) to avoid (multiple) column slicing (as needed in OP)
demonstrates the use of Private Constants on module top (used here for enumerating the sub-arrays within the jagged array
demonstrates a help procedure to provide for a correcty dimensioned jagged array:
Example code
Option Explicit ' declaration head of code module (forching variable declarations)
Private Const LineNum As Long = 0 ' enumerate sub-arrays within jagged array
Private Const Pipe As Long = 1
Private Const Service As Long = 2
Sub SplitLinesIntoJaggedArray()
'I. Set Worksheet object to memory ' fully qualify any range references!
Dim ws As Worksheet ' declare ws as of worksheet object type
Set ws = Tabelle1 ' << use the project's sheet Code(Name)
'set ws = ThisWorkbook.Worksheets("Sheet1") ' or: via a sheet's tabular name (needn't be the same)
With ws ' With .. End With structure, note the following "."-prefixes
'II.Definitions
'a) assign target start cell addresses to array tgt
Dim tgt As Variant
tgt = Split("J19,B19,F19", ",") ' split requires "Dim tgt" without brackets to avoid Error 13
'b) define source range object and set to memory
' Note: tgt(LinNum) equalling tgt(0) equalling "J19"
Dim src As Range
Set src = .Range(tgt(LineNum), .Range(tgt(0)).End(xlDown)) ' showing both enumerations only for demo:-)
Dim CountOfRows As Long: CountOfRows = src.Rows.Count ' count rows in source range
'c) provide for a correctly dimensioned jagged array to hold all 2-dim data arrays (three columns)
Dim JaggedArray() As Variant
BuildJagged JaggedArray, CountOfRows ' << call help procedure BuildJaggedArray
'III.Assign column data to JaggedArray
'a) assign LineNum column as 2-dim datafield to JaggedArray(LineNum)
JaggedArray(LineNum) = src.Value
'b) assign LineNum splits to JaggedArray(Pipe) and JaggedArray(Service)
Dim Counter As Long
For Counter = 1 To CountOfRows
'1. Pipe DN
JaggedArray(Pipe)(Counter, 1) = Split(JaggedArray(LineNum)(Counter, 1), "-")(0)
'2. Service Code
JaggedArray(Service)(Counter, 1) = Split(JaggedArray(LineNum)(Counter, 1), "-")(1)
Next Counter
'IV.Write result columns of jagged array to target addresses
' Note: tgt(Pipe)=tgt(1)="B19", tgt(Service)=tgt(2)="F19"
Dim elem As Long
For elem = Pipe To Service
.Range(tgt(elem)).Resize(CountOfRows, 1) = JaggedArray(elem)
Next
End With
End Sub
*Help procedure BuildJagged
Note that the first procedure argument passes the jagged array By Reference (=default, if not explicitly passed ByVal).
This means that any further actions within the help procedure have an immediate effect on the original array.
Sub BuildJagged(ByRef JaggedArray, ByVal CountOfRows As Long)
'Purpose: provide for correct dimensions of the jagged array passed By Reference
ReDim JaggedArray(LineNum To Service) ' include LineNum as data base (gets dimmed later)
Dim tmp() As Variant
ReDim tmp(1 To CountOfRows, 1 To 1)
Dim i As Long
For i = Pipe To Service ' suffices here to start from 1=Pipe to 2=Service
JaggedArray(i) = tmp
Next i
End Sub
Further link
Error in finding last used cell in Excel VBA
Related
I created and defined an array in VBA:
A_Array(2,4) As Variant (Option Base 1)
I want to match numbers in the 2nd column against specific criteria, for example, which row in the second column contains the number "1". Once I find the match then I want to use the corresponding value in the first column to create a variable. How do I specify the range, in this case an entire column of a VBA created array, when i use the index and match functions?
Variable = Worksheet.Function.Index(A_Array, Worksheet.Function.Match(1, **?Second_ Column of A_Array?**,0),**?First Column of A_Array?**)
How do i specify the first column of A_Array inside the Match function above and how do I specify the second column of the A_Array inside the Index function.
Thanks in advance for any help.
Just loop the rows and test, with variant arrays it will be quick.
Dim A_Array(2, 4) As Variant
'fill array
Dim i As Long
For i = LBound(A_Array, 1) To UBound(A_Array, 1)
If A_Array(i, 2) = 1 Then
variable = A_Array(i, 1)
Exit For
End If
Next i
If you are wanting to find an array element equal to 1, this is the slicing approach which doesn't require a loop.
Most of this code is populating an array and showing it on a sheet for the purposes of illustrating the results, so you probably won't need any of that.
Sub x()
Dim A_Array(1 To 4, 1 To 2) As Variant, i As Long, variable As Variant, v As Variant
For i = LBound(A_Array, 1) To UBound(A_Array, 1) 'just populating array with any old stuff so you won't need
A_Array(i, 1) = i * 2
A_Array(i, 2) = i * 3
Next i
A_Array(2, 2) = 1 'make sure something in 2nd column is 1
Range("A1").Resize(4, 2).Value = A_Array
v = Application.Match(1, Application.Index(A_Array, , 2), 0) 'returns position of 1 in second column (or error if no match)
if isnumeric(v) then variable = A_Array(v, 1) 'find corresponding element in 1st column
Range("D1").Value = variable
End Sub
I have a column of a list object with some non empty values at the beginning. Just assume the first 15 values are not blank.
I know it is possible to pass the values of a range to an array like this:
Dim mylistObject As ListObject
Set mylistObject = ThisWorkbook.Sheets("training").ListObjects(1)
Dim theArray() As Variant
theArray = mylistObject.listcolumn(1).DataBodyRange.value
The question is how can I pass only the non blank values.
I know how to do it with loops but the key point here is speed, if the listobject has hundreds of rows and the operation is done tens of times it takes too long.
I also know that it might be possible to calculate the number of non blank cells and redim the array accordingly and loop through values. still not elegant.
Any idea? there should be a way to tell in VBA language
mylistObject.listcolumn(1).DataBodyRange.value
' but not all the range but the non empty ones.
Thanks a lot
Using the possibilities of the Application.Index function
Demonstrate an easy approach to create and transform the listbox'es column data Array:
Get all data of first column (including blanks) as already shown in the original post (BTW the correct syntax in the array assignment is theArray = mylistObject.ListColumns(1).DataBodyRange.Value with a final "s" in .ListColumns)
Eliminate blank row numbers using the advanced features of the Application.Index function and a subordinated function call (getNonBlankRowNums())
Basic transformation syntax by one code line:
newArray = Application.Index(oldArray, Application.Transpose(RowArray), ColumnArray)
where RowArray / ColumnArray stands for an array of (remaining) row or column numbers.
Related link: Some peculiarities of the the Application.Index function
Sub NonBlanks()
' Note: encourageing to reference a sheet via CodeName instead of Thisworkbook.Worksheets("training")
' i.e. change the (Name) property in the VBE properties tool window (F4) for the referenced worksheet
' (c.f. https://stackoverflow.com/questions/58507542/set-up-variable-to-refer-to-sheet/58508735#58508735)
Dim mylistObject As ListObject
Set mylistObject = training.ListObjects(1)
' [1] Get data of first column (including blanks)
Dim theArray As Variant
theArray = mylistObject.ListColumns(1).DataBodyRange.Value ' LISTCOLUMNS with final S!!
' [2] eliminate blank row numbers
theArray = Application.Index(theArray, Application.Transpose(getNonBlankRowNums(theArray)), Array(1))
End Sub
Function getNonBlankRowNums(arr, Optional ByVal col = 1) As Variant()
' Purpose: return 1-dim array with remaining non-blank row numbers
Dim i&, ii&, tmp
ReDim tmp(1 To UBound(arr))
For i = 1 To UBound(arr)
If arr(i, col) <> vbNullString Then ' check for non-blanks
ii = ii + 1 ' increment temporary items counter
tmp(ii) = i ' enter row number
End If
Next i
ReDim Preserve tmp(1 To ii) ' redim to final size preserving existing items
' return function value (variant array)
getNonBlankRowNums = tmp
End Function
I'm trying to make something that
loops through a range (header range) of values and collects them into an array or whatever
make a dictionary of arrays with keys that are the values in the range
loop through worksheets looking for those keys
for each key it finds,
a. make an array of the values below
b. pad all the arrays so their the same length
c. concatenate it to the array stored in the dictionary with the same key
copy the concatenated values back to the cells below the header range
I did 1,2,4 and 5. I skipped 3, because that's easy and I'll do it later. But 4 is tricky because I can't get a handle on how the dictionary and arrays work. I tried to make a dictionary of arrays, but they're making copies instead of references and sometimes the copies are empty. I don't know.
In javascript, it would just be:
make a dict = {}
loop through the values and do dict[value] = []
then dict[value].concatenate(newestarray)
Then flip the dict back in to an array with a for(var k in dict){} which in google sheets you would have to transpose. Annoying, but not terrible.
Then in the end, some function to put it back into the worksheet, which in google sheets would be trivial.
Here's my code for the 4 part:
With rws
For Each Key In headerdict 'loop through the keys in the dict
Set rrng = .Cells.Find(key, , _ 'find the key in the sheet
Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart, _
Excel.XlSearchOrder.xlByRows, Excel.XlSearchDirection.xlNext, False)
If rrng Is Not Empty Then
'find last cell in column of data
Set rdrng = .Cells(rws.Rows.Count, rrng.Column).End(xlUp)
'get range for column of data
Set rrng = .Range(.Cells(rrng.Row + 1, rrng.Column), _
.Cells(rdrng.Row, rdrng.Column))
rArray = rrng.Value 'make an array
zMax = Max(UBound(rArray, 2), zMax) 'set max list length
fakedict(Key) = rArray 'place array in fake dict for later smoothing
End If
Next
End With
For Each Key In fakedict 'now smooth the array
If fakedict(Key) Is Not Nothing Then
nArray = fakedict(Key)
ReDim Preserve nArray(1 To zMax, 1 To 1) 'resize the array
Else
ReDim nArray(1 To zMax, 1 To 1) 'or make one from nothing
End If
fakedict(Key) = nArray 'add to fake dict
Next
Then later I can combine into the real dict. So my question is how do I resize the array? I don't think redim preserve is the best way. Others have mangled with collections, but I have too much pandas and python thinking. I'm used to deal with vectors, not munge elements. Any ideas?
I was not sure if you needed to use a dictionary of arrays to achieve this; if I was doing it I would just copy blocks of cells between sheets directly.
First bit - identify where the headers are:
Option Explicit
' Get the range that includes the headers
' Assume the headers are in sheet "DB" in row 1
Private Function GetHeaders() As Range
Dim r As Range
Set r = [DB!A1]
Set GetHeaders = Range(r, r.End(xlToRight))
End Function
Second, identify the sheets to scan (I assumed they're in the same workbook)
' Get all sheets in this workbook that aren't the target DB sheet
Private Function GetSheets() As Collection
Dim sheet As Worksheet
Dim col As New Collection
For Each sheet In ThisWorkbook.Worksheets
If sheet.Name <> "DB" Then col.Add sheet
Next sheet
Set GetSheets = col
End Function
Now, scan through and copy cells
' Main function, loop through all headers in all sheets
' and copy data
Sub CollectData()
Dim sheets As Collection, sheet As Worksheet
Dim hdrs As Range, hdr As Range
Dim found As Range
' This is the row we are writing into on DB
Dim currentrow As Integer
' This is the maximum number of entries under a header on this sheet, used for padding
Dim maxcount As Integer
Set sheets = GetSheets
Set hdrs = GetHeaders
currentrow = 1
For Each sheet In sheets
maxcount = 0
For Each hdr In hdrs.Cells
' Assume each header appears only once in each sheet
Set found = sheet.Cells.Find(hdr.Value)
If Not found Is Nothing Then
' Check if there is anything underneath
If Not IsEmpty(found.Offset(1).Value) Then
Set found = Range(found.Offset(1), found.End(xlDown))
' Note the number of items if it's more that has been found so far
If maxcount < found.Count Then maxcount = found.Count
' Copy cells
Range(hdr.Offset(currentrow), hdr.Offset(currentrow + found.Count - 1)) = found.Cells.Value
End If
End If
Next hdr
' Move down ready for the next sheet
currentrow = currentrow + maxcount
Next sheet
End Sub
I wrote this in Excel 2016 and tested that it worked based on my assumption of how your data is laid out.
Problem: I am comparing two columns of names. If a name from the primary column matches a name in the secondary column, then I would like to add the matching name to an array of strings.
Function 1: This boolean function should indicate whether there is a match:
Function Match(name As String, s As Worksheet, column As Integer) As Boolean
Dim i As Integer
i = 2
While s.Cells(i, column) <> ""
If s.Cells(i, column).Value = name Then
Match = True
End If
i = i + 1
Wend
Match = False
End Function
Function 2: This function should add the matching name to a dynamic array of strings. Here I am somewhat stuck as I am new to arrays- any suggestions?
Function AddToArray(ys) As String()
Dim a() As String
Dim size As Integer
Dim i As Integer
Dim sh As Worksheet
Dim rw As Range
size = 0
ReDim Preserve a(size)
For Each rw In sh.Rows
If Match(sh.Cells(rw.Row, 1), s, column) = True Then
??
size = size + 1
End Function
Here is one solution. I scrapped your Match function and replaced it with a Find function.
Option Explicit
Sub AddToArray()
Dim primaryColumn As Range, secondaryColumn As Range, matchedRange As Range
Dim i As Long, currentIndex As Long
Dim matchingNames As Variant
With ThisWorkbook.Worksheets("Sheet1")
Set primaryColumn = .Range("A1:A10")
Set secondaryColumn = .Range("B1:B10")
End With
'Size your array so no dynamic resizing is necessary
ReDim matchingNames(1 To primaryColumn.Rows.Count)
currentIndex = 1
'loop through your primary column
'add any values that match to the matchingNames array
For i = 1 To primaryColumn.Rows.Count
On Error Resume Next
Set matchedRange = secondaryColumn.Find(primaryColumn.Cells(i, 1).Value)
On Error GoTo 0
If Not matchedRange Is Nothing Then
matchingNames(currentIndex) = matchedRange.Value
currentIndex = currentIndex + 1
End If
Next i
'remove unused part of array
ReDim Preserve matchingNames(1 To currentIndex - 1)
'matchingNames array now contains just the values you want... use it how you need!
Debug.Print matchingNames(1)
Debug.Print matchingNames(2)
'...etc
End Sub
Extra comments
There is no need to create your own Match function because it already exists in VBA:
Application.Match()
WorksheetFunction.Match()
and as I mentioned above you can also achieve the same result with the Find function which is my preference here because I prefer the way you can check for no matches (other methods throw less convenient errors).
Finally, I also opted to restructure your code into one Sub rather than two Functions. You weren't returning anything with your AddToArray function which pretty much means by definition it should actually be a Sub
As I stated in a comment to the question, there are a couple of problems in your code before adding anything to the array that will prevent this from working, but assuming that this was caused by simplifying the code to ask the question, the following should work.
The specific question that you are asking, is how to populate the array while increasing its size when needed.
To do this, simply do this:
Instead of:
ReDim Preserve a(size)
For Each rw In sh.Rows
If Match(sh.Cells(rw.Row, 1), s, column) = True Then
Reorder this so that it is:
For Each rw In sh.Rows
If Match(sh.Cells(rw.Row, 1), s, column) = True Then
ReDim Preserve a(size) 'increase size of array
a(size) = sh.Cells(rw.Row,1) 'put value in array
size = size + 1 'create value for size of next array
End If
Next rw
....
This probably isn't the best way to accomplish this task, but this is what you were asking to do. First, increasing the array size EVERY time is going to waste a lot of time. It would be better to increase the array size every 10 or 100 matches instead of every time. I will leave this exercise to you. Then you could resize it at the end to the exact size you want.
I'm having a seemingly basic problem but can't find any resources addressing it.
Simply put, I just want to load the contents of a Range of cells (all one column) into an Array.
I am able to accomplish this by means of
DirArray = Array(Range("A1"), Range("A2"))
But for some reason, I cannot create the array when expressed this way:
DirArray = Array(Range("A1:A2"))
My real Range is much longer (and may vary in length), so I don't want to have to individually enumerate the cells this way. Can anyone tell me how to properly load a whole Range into an Array?
With the latter code:
MsgBox UBound(DirArray, 1)
And
MsgBox UBound(DirArray)
Return 0, whereas with the former they return 1.
Just define the variable as a variant, and make them equal:
Dim DirArray As Variant
DirArray = Range("a1:a5").Value
No need for the Array command.
If we do it just like this:
Dim myArr as Variant
myArr = Range("A1:A10")
the new array will be with two dimensions. Which is not always somehow comfortable to work with:
To get away of the two dimensions, when getting a single column to array, we may use the built-in Excel function “Transpose”. With it, the data becomes in one dimension:
If we have the data in a row, a single transpose will not do the job. We need to use the Transpose function twice:
Note: As you see from the screenshots, when generated this way, arrays start with 1, not with 0. Just be a bit careful.
Edit June.2021:
In newer versions of Excel, the function is: Application.WorksheetFunction.Transpose()
Using Value2 gives a performance benefit. As per Charles Williams blog
Range.Value2 works the same way as Range.Value, except that it does not check the cell format and convert to Date or Currency. And thats probably why its faster than .Value when retrieving numbers.
So
DirArray = [a1:a5].Value2
Bonus Reading
Range.Value: Returns or sets a Variant value that represents the value of the specified range.
Range.Value2: The only difference between this property and the Value property is that the Value2 property doesn't use the Currency and Date data types.
This function returns an array regardless of the size of the range.
Ranges will return an array unless the range is only 1 cell and then it returns a single value instead. This function will turn the single value into an array (1 based, the same as the array's returned by ranges)
This answer improves on previous answers as it will return an array from a range no matter what the size. It is also more efficient that other answers as it will return the array generated by the range if possible. Works with single dimension and multi-dimensional arrays
The function works by trying to find the upper bounds of the array. If that fails then it must be a single value so we'll create an array and assign the value to it.
Public Function RangeToArray(inputRange As Range) As Variant()
Dim size As Integer
Dim inputValue As Variant, outputArray() As Variant
' inputValue will either be an variant array for ranges with more than 1 cell
' or a single variant value for range will only 1 cell
inputValue = inputRange
On Error Resume Next
size = UBound(inputValue)
If Err.Number = 0 Then
RangeToArray = inputValue
Else
On Error GoTo 0
ReDim outputArray(1 To 1, 1 to 1)
outputArray(1,1) = inputValue
RangeToArray = outputArray
End If
On Error GoTo 0
End Function
In addition to solutions proposed, and in case you have a 1D range to 1D array, i prefer to process it through a function like below. The reason is simple: If for any reason your range is reduced to 1 element range, as far as i know the command Range().Value will not return a variant array but just a variant and you will not be able to assign a variant variable to a variant array (previously declared).
I had to convert a variable size range to a double array, and when the range was of 1 cell size, i was not able to use a construct like range().value so i proceed with a function like below.
Public Function Rng2Array(inputRange As Range) As Double()
Dim out() As Double
ReDim out(inputRange.Columns.Count - 1)
Dim cell As Range
Dim i As Long
For i = 0 To inputRange.Columns.Count - 1
out(i) = inputRange(1, i + 1) 'loop over a range "row"
Next
Rng2Array = out
End Function
I'm another vote for iterating through the cells in the range. Unless somebody has found a workaround, my experience trying to assign the range directly to a Variant has been that it works fine (albeit returning a 2-dimensional array when I really only need 1D) except if my range has multiple areas, like for example, when I want just the visible cells in a column of a filtered table, or if I have ctrl-selected different blocks of cells on a sheet.
Iterating through all the cells in the range with a for..each loop always produces the results I expect.
Public Function RangeToArray(ByRef myRange As Range)
Dim i As Long
Dim individualCell As Range
ReDim myArray(myRange.Count - 1)
For Each individualCell In myRange
myArray(i) = individualCell.Text ' or maybe .Value
i = i + 1
Next
RangeToArray = myArray
End Function
I wanted to add this as a comment to Paolo's answer since it's pretty similar but I am a newbie and don't have enough reputation, so here's another slightly different answer.
Adding to #Vityata 's answer, below is the function I use to convert a row / column vector in a 1D array:
Function convertVecToArr(ByVal rng As Range) As Variant
'convert two dimension array into a one dimension array
Dim arr() As Variant, slicedArr() As Variant
arr = rng.value 'arr = rng works too (https://bettersolutions.com/excel/cells-ranges/vba-working-with-arrays.htm)
If UBound(arr, 1) > UBound(arr, 2) Then
slicedArr = Application.WorksheetFunction.Transpose(arr)
Else
slicedArr = Application.WorksheetFunction.index(arr, 1, 0) 'If you set row_num or column_num to 0 (zero), Index returns the array of values for the entire column or row, respectively._
'To use values returned as an array, enter the Index function as an array formula in a horizontal range of cells for a row,_
'and in a vertical range of cells for a column.
'https://usefulgyaan.wordpress.com/2013/06/12/vba-trick-of-the-week-slicing-an-array-without-loop-application-index/
End If
convertVecToArr = slicedArr
End Function
Transpose is a great advice.
I have multiple arrays in my app. Some global, some local, some loaded from ranges and some created programatically.
I had numerous problems with dimensioning. Now, with transpose they are all one dimension.
I did have to modify code slightly, because one version runs on Excel 2003 and another (slower) on 2010.
Caution: You will have to Transpose the array again, when saving it to a range.
Using the shape of the Range
Another approach in creating a function for ArrayFromRange would be using the shape and size of the Range to determine how we should structure the array. This way we don't have to load the data into an intermediate array to determine the dimension.
For instance, if the target range is only one cell, then we know we want to return an array with the single value in it Array(target.value).
Below is the complete function that should deal with all cases. Note, this uses the same technique of using the Application.Transpose method to reshape the array.
' Helper function that returns an array from a range with the
' correct dimensions. This fixes the issue of single values
' not returning as an array, and when a 2 dimension array is returned
' when it only has 1 dimension of data.
'
' #author Robert Todar <robert#roberttodar.com>
Public Function ArrayFromRange(ByVal target As Range) As Variant
Select Case True
' Single cell
Case target.Cells.Count = 1
ArrayFromRange = Array(target.Value)
' Single Row
Case target.Rows.Count = 1
ArrayFromRange = Application.Transpose( _
Application.Transpose(target.Value) _
)
' Single Column
Case target.Columns.Count = 1
ArrayFromRange = Application.Transpose(target.Value)
' Multi dimension array
Case Else
ArrayFromRange = target.Value
End Select
End Function
Testing the ArrayFromRange function
As a bonus, here are the tests that I ran to check that this function works.
' #requires {function} ArrayDimensionLength
' #requires {function} ArrayCount
Private Sub testArrayFromRange()
' Setup a new workbook/worksheet for
' adding testing data
Dim testWorkbook As Workbook
Set testWorkbook = Workbooks.Add
Dim ws As Worksheet
Set ws = testWorkbook.Worksheets(1)
' Add sample data for testing.
ws.Range("A1:A2") = Application.Transpose(Array("A1", "A2"))
ws.Range("B1:B2") = Application.Transpose(Array("B1", "B2"))
' This section will run all the tests.
Dim x As Variant
' Single cell
x = ArrayFromRange(ws.Range("A1"))
Debug.Assert ArrayDimensionLength(x) = 1
Debug.Assert ArrayCount(x) = 1
' Single Row
x = ArrayFromRange(ws.Range("A1:B1"))
Debug.Assert ArrayDimensionLength(x) = 1
Debug.Assert ArrayCount(x) = 2
' Single Column
x = ArrayFromRange(ws.Range("A1:A2"))
Debug.Assert ArrayDimensionLength(x) = 1
Debug.Assert ArrayCount(x) = 2
' Multi Column
x = ArrayFromRange(ws.Range("A1:B2"))
Debug.Assert ArrayDimensionLength(x) = 2
Debug.Assert ArrayCount(x) = 4
' Cleanup testing environment
testWorkbook.Close False
' Print result
Debug.Print "testArrayFromRange: PASS"
End Sub
Helper functions for the tests
In my tests I used two helper functions: ArrayCount, and ArrayDimensionLength. These are listed below for reference.
' Returns the length of the dimension of an array
'
' #author Robert Todar <robert#roberttodar.com>
Public Function ArrayDimensionLength(sourceArray As Variant) As Integer
On Error GoTo catch
Do
Dim currentDimension As Long
currentDimension = currentDimension + 1
' `test` is used to see when the
' Ubound throws an error. It is unused
' on purpose.
Dim test As Long
test = UBound(sourceArray, currentDimension)
Loop
catch:
' Need to subtract one because the last
' one errored out.
ArrayDimensionLength = currentDimension - 1
End Function
' Get count of elements in an array regardless of
' the option base. This Looks purely at the size
' of the array, not the contents within them such as
' empty elements.
'
' #author Robert Todar <robert#roberttodar.com>
' #requires {function} ArrayDimensionLength
Public Function ArrayCount(ByVal sourceArray As Variant) As Long
Dim dimensions As Long
dimensions = ArrayDimensionLength(sourceArray)
Select Case dimensions
Case 0
ArrayCount = 0
Case 1
ArrayCount = (UBound(sourceArray, 1) - LBound(sourceArray, 1)) + 1
Case Else
' Need to set arrayCount to 1 otherwise the
' loop will keep multiplying by zero for each
' iteration
ArrayCount = 1
Dim dimension As Long
For dimension = 1 To dimensions
ArrayCount = ArrayCount * _
((UBound(sourceArray, dimension) - LBound(sourceArray, dimension)) + 1)
Next
End Select
End Function