VBA using ubound on a multidimensional array - arrays

Ubound can return the max index value of an array, but in a multidimensional array, how would I specify WHICH dimension I want the max index of?
For example
Dim arr(1 to 4, 1 to 3) As Variant
In this 4x3 array, how would I have Ubound return 4, and how would I have Ubound return 3?

ubound(arr, 1)
and
ubound(arr, 2)

You need to deal with the optional Rank parameter of UBound.
Dim arr(1 To 4, 1 To 3) As Variant
Debug.Print UBound(arr, 1) '◄ returns 4
Debug.Print UBound(arr, 2) '◄ returns 3
More at: UBound Function (Visual Basic)

[This is a late answer addressing the title of the question (since that is what people would encounter when searching) rather than the specifics of OP's question which has already been answered adequately]
Ubound is a bit fragile in that it provides no way to know how many dimensions an array has. You can use error trapping to determine the full layout of an array. The following returns a collection of arrays, one for each dimension. The count property can be used to determine the number of dimensions and their lower and upper bounds can be extracted as needed:
Function Bounds(A As Variant) As Collection
Dim C As New Collection
Dim v As Variant, i As Long
On Error GoTo exit_function
i = 1
Do While True
v = Array(LBound(A, i), UBound(A, i))
C.Add v
i = i + 1
Loop
exit_function:
Set Bounds = C
End Function
Used like this:
Sub test()
Dim i As Long
Dim A(1 To 10, 1 To 5, 4 To 10) As Integer
Dim B(1 To 5) As Variant
Dim C As Variant
Dim sizes As Collection
Set sizes = Bounds(A)
Debug.Print "A has " & sizes.Count & " dimensions:"
For i = 1 To sizes.Count
Debug.Print sizes(i)(0) & " to " & sizes(i)(1)
Next i
Set sizes = Bounds(B)
Debug.Print vbCrLf & "B has " & sizes.Count & " dimensions:"
For i = 1 To sizes.Count
Debug.Print sizes(i)(0) & " to " & sizes(i)(1)
Next i
Set sizes = Bounds(C)
Debug.Print vbCrLf & "C has " & sizes.Count & " dimensions:"
For i = 1 To sizes.Count
Debug.Print sizes(i)(0) & " to " & sizes(i)(1)
Next i
End Sub
Output:
A has 3 dimensions:
1 to 10
1 to 5
4 to 10
B has 1 dimensions:
1 to 5
C has 0 dimensions:

UBound(myArray, 1) returns the number of rows in 2d array
UBound(myArray, 2) returns the number of columns in 2d array
However, let's go 1 step further and assume that you need the last row and last column of range, that has been written as a 2d array. That row (or column) should be converted to a 1d array. E.g. if our 2d array looks like this:
Then running the code below, will give you 2 1D arrays, that are the last column and last row:
Sub PrintMultidimensionalArrayExample()
Dim myRange As Range: Set myRange = Range("a1").CurrentRegion
Dim myArray As Variant: myArray = myRange
Dim lastRowArray As Variant: lastRowArray = GetRowFromMdArray(myArray, UBound(myArray, 1))
Dim lastColumnArray As Variant
lastColumnArray = GetColumnFromMdArray(myArray, UBound(myArray, 2))
End Sub
Function GetColumnFromMdArray(myArray As Variant, myCol As Long) As Variant
'returning a column from multidimensional array
'the returned array is 0-based, but the 0th element is Empty.
Dim i As Long
Dim result As Variant
Dim size As Long: size = UBound(myArray, 1)
ReDim result(size)
For i = LBound(myArray, 1) To UBound(myArray, 1)
result(i) = myArray(i, myCol)
Next
GetColumnFromMdArray = result
End Function
Function GetRowFromMdArray(myArray As Variant, myRow As Long) As Variant
'returning a row from multidimensional array
'the returned array is 0-based, but the 0th element is Empty.
Dim i As Long
Dim result As Variant
Dim size As Long: size = UBound(myArray, 2)
ReDim result(size)
For i = LBound(myArray, 2) To UBound(myArray, 2)
result(i) = myArray(myRow, i)
Next
GetRowFromMdArray = result
End Function

In addition to the already excellent answers, also consider this function to retrieve both the number of dimensions and their bounds, which is similar to John's answer, but works and looks a little differently:
Function sizeOfArray(arr As Variant) As String
Dim str As String
Dim numDim As Integer
numDim = NumberOfArrayDimensions(arr)
str = "Array"
For i = 1 To numDim
str = str & "(" & LBound(arr, i) & " To " & UBound(arr, i)
If Not i = numDim Then
str = str & ", "
Else
str = str & ")"
End If
Next i
sizeOfArray = str
End Function
Private Function NumberOfArrayDimensions(arr As Variant) As Integer
' By Chip Pearson
' http://www.cpearson.com/excel/vbaarrays.htm
Dim Ndx As Integer
Dim Res As Integer
On Error Resume Next
' Loop, increasing the dimension index Ndx, until an error occurs.
' An error will occur when Ndx exceeds the number of dimension
' in the array. Return Ndx - 1.
Do
Ndx = Ndx + 1
Res = UBound(arr, Ndx)
Loop Until Err.Number <> 0
NumberOfArrayDimensions = Ndx - 1
End Function
Example usage:
Sub arrSizeTester()
Dim arr(1 To 2, 3 To 22, 2 To 9, 12 To 18) As Variant
Debug.Print sizeOfArray(arr())
End Sub
And its output:
Array(1 To 2, 3 To 22, 2 To 9, 12 To 18)

Looping D3 ways;
Sub SearchArray()
Dim arr(3, 2) As Variant
arr(0, 0) = "A"
arr(0, 1) = "1"
arr(0, 2) = "w"
arr(1, 0) = "B"
arr(1, 1) = "2"
arr(1, 2) = "x"
arr(2, 0) = "C"
arr(2, 1) = "3"
arr(2, 2) = "y"
arr(3, 0) = "D"
arr(3, 1) = "4"
arr(3, 2) = "z"
Debug.Print "Loop Dimension 1"
For i = 0 To UBound(arr, 1)
Debug.Print "arr(" & i & ", 0) is " & arr(i, 0)
Next i
Debug.Print ""
Debug.Print "Loop Dimension 2"
For j = 0 To UBound(arr, 2)
Debug.Print "arr(0, " & j & ") is " & arr(0, j)
Next j
Debug.Print ""
Debug.Print "Loop Dimension 1 and 2"
For i = 0 To UBound(arr, 1)
For j = 0 To UBound(arr, 2)
Debug.Print "arr(" & i & ", " & j & ") is " & arr(i, j)
Next j
Next i
Debug.Print ""
End Sub

Related

How do I write an array to a range of cells after redimming the array?

My goal is to select a column of about 300,000 cells and round each cell's value to two decimal places.
I found that looping an array is far faster than looping through cells.
It is much faster if I have the whole array post its data into the cells after the loop rather than during because again posting any data in a loop takes too much time.
Is there a way to write all the values from the new array ("varArray") after the loop is completed?
Sub RoundedTwoDecimalPlaces()
Dim i As Integer
Dim MyArray() As Variant ' Declare dynamic array.
Dim LastRow As Integer
Dim lStart As Double
Dim lEnd As Double
lStart = Timer
LastRow = Cells(1, Selection.Column).End(xlDown).Row
MyArray = Range("a1:a8").Value2
ReDim MyArray(LastRow) ' Resize to x amount of elements.
For i = 1 To LastRow
MyArray(i) = Round(Cells(i, Selection.Column), 2) ' Initialize array.
Next i
''this is where I can't get my array to post into the cells dynamically.
Selection.Value = MyArray()
''to see the amount of time it takes to finish.
'' My goal is to do 300,000 lines quickly
lEnd = Timer
Debug.Print "Duration = " & (lEnd - lStart) & " seconds"
End Sub
You can get the array directly from the range and then restore the altered values:
Sub RoundedTwoDecimalPlaces()
Dim i As Integer
Dim arr As Variant
Dim lStart As Double
Dim ws As Worksheet, col as Long
Set ws = ActiveSheet
col = Selection.Column
lStart = Timer
With ws.Range(ws.Cells(1, col), ws.Cells(1, col).End(xlDown))
arr = .Value
For i = 1 to Ubound(arr, 1)
arr(i, 1) = Round(arr(i, 1), 2)
Next i
.Value = arr
end with
Debug.Print "Duration = " & (Timer - lStart) & " seconds"
End Sub
Here is how I did it using #Tim Williams Code.
I had to loop it because the array has a max character limit.
Here is the finished code:
Sub loopthrough()
Dim i As Integer
Dim arr As Variant
Dim arr1 As Variant
Dim arr2 As Variant
Dim lStart As Double
Dim ws As Worksheet, col As Long
LastRow = Cells(1, Selection.Column).End(xlDown).Row
Set ws = ActiveSheet
col = Selection.Column
lStart = Timer
If LastRow < 30001 Then
With ws.Range(ws.Cells(1, col), ws.Cells(1, col).End(xlDown))
arr = .Value2
For i = 1 To UBound(arr, 1)
If IsNumeric(arr(i, 1)) Then
arr(i, 1) = Round(arr(i, 1), 2)
Else
arr(i, 1) = arr(i, 1)
End If
Next i
.Value2 = arr
End With
Else ''if selection is more than 30,000 lines.
n = 1
Z = 30000
Do While Z < LastRow
With ws.Range(ws.Cells(n, col), ws.Cells(Z, col))
arr = .Value2
For i = 1 To UBound(arr, 1)
If IsNumeric(arr(i, 1)) Then
arr(i, 1) = Round(arr(i, 1), 2)
Else
arr(i, 1) = arr(i, 1)
End If
Next i
.Value2 = arr
End With
n = n + 30000
Z = Z + 30000
Loop
With ws.Range(ws.Cells(n, col), ws.Cells(n, col).End(xlDown))
arr = .Value2
For i = 1 To UBound(arr, 1)
If IsNumeric(arr(i, 1)) Then
arr(i, 1) = Round(arr(i, 1), 2)
Else
arr(i, 1) = arr(i, 1)
End If
Next i
.Value2 = arr
End With
End If
Debug.Print "Duration = " & (Timer - lStart) & " seconds"
End Sub

How to parse dynamic array arguments to a variable in excel vba

※ This question is a continuation of below problem
How to use nested loop for a Matrix cell in excel vba
I would like to pass dynamic Array(arguments), and i was trying below, but it is not working correctly. Could you please help me.
Dim StartrowArr, Startrow1Arr, J As Integer
Dim flRow, dtRow As String
Set filRng = Worksheets("Sheet1").Range("C1:C50")
Set dtlRng = Worksheets("Sheet1").Range("F1:F50")
For Each cell In filRng
If cell.Value <> "" Then
ftRow = ftRow & cell.Row & ","
End If
Next cell
ftRow = Left(ftRow, Len(ftRow) - 1)
Debug.Print ftRowNo
For Each cell In dtlRng
If cell.Value <> "" Then
dtRow = dtRow & cell.Row & ","
End If
Next cell
dtRow = Left(dtRow, Len(dtRow) - 1)
Debug.Print dtRow
StartrowArr = Array(filRowNo) ※ dynamic array args
Startrow1Arr = Array(dtlRowNo)
but after initializing Array(args) like above, it returns error 1004 on [Startrow1, init with 0]. I also tried CInt(ftRow) to typecast to Integer from String. nothings changed. Moreover, log shows that Startrow, Startrow1 got values like below.
Startrow: 2, 4, 7
Startrow1: 2611 ※ should be 2, 6, 11
However, If I initialize the StartrowArr = Array(2,4,7), statically. it works perfect.
How can I pass the arguments correctly to StartrowArr and Startrow1Arr.
To making Dynamic array, use redim preserve .
Sub test()
Dim StartrowArr(), Startrow1Arr(), J As Integer
Dim flRow, dtRow As String
Dim Cell As Range
Dim k As Long, n As Long
Set filRng = Worksheets("Sheet1").Range("C1:C50")
Set dtlRng = Worksheets("Sheet1").Range("F1:F50")
For Each Cell In filRng
If Cell.Value <> "" Then
'ftRow = ftRow & cell.Row & ","
ReDim Preserve StartrowArr(k)
StartrowArr(k) = Cell.Row
k = k + 1
End If
Next Cell
'ftRow = Left(ftRow, Len(ftRow) - 1)
Debug.Print Join(StartrowArr, ",")
For Each Cell In dtlRng
If Cell.Value <> "" Then
'dtRow = dtRow & Cell.Row & ","
ReDim Preserve Startrow1Arr(n)
Startrow1Arr(n) = Cell.Row
n = n + 1
End If
Next Cell
'dtRow = Left(dtRow, Len(dtRow) - 1)
Debug.Print Join(Startrow1Arr, ",")
'StartrowArr = Array(mapRowNo) '※ dynamic array args
'Startrow1Arr = Array(tcRowNo)
End Sub

VBA - MsgBox a 2D Array (Matrix)

I am trying to visualize a 2D Matrix (Array) using a MsgBox, but the code I have doesn't give me the correct representation.
Sub test()
Dim M(22, 7) As Double
TwoD_Array_Matrix_In_MSGBOX (M)
End Sub
'_________________________________________________________________________
Public Function TwoD_Array_Matrix_In_MSGBOX(arr As Variant)
h = UBound(arr, 1)
w = UBound(arr, 2)
'MsgBox ("h = " & CStr(h + 1) & vbCrLf & "w = " & CStr(w + 1)) ' to check if the width and hight of the Matrix are correct
Dim msg As String
For i = 0 To w
For ii = 0 To h
msg = msg & arr(ii, i) & vbTab
Next ii
msg = msg & vbCrLf
Next i
MsgBox msg
End Function
This is the result I get:
You have w and h interchanged.
Dim msg As String
For i = 0 To h
For ii = 0 To w
msg = msg & arr(i, ii) & vbTab
Next ii
msg = msg & vbCrLf
Next i
MsgBox msg
this works perfectly for me
Private Sub this()
Dim this(22, 7) As Integer
Dim msg$
For i = LBound(this, 1) To UBound(this, 1)
For j = LBound(this, 2) To UBound(this, 2)
msg = msg & this(i, j) & vbTab
Next j
Next i
MsgBox msg
End Sub
It might be more flexible to write a function which returns a string, a sort of 2-dimensional join, which allows you to choose both the item delimiter (defaulting to vbTab) and the row delimiter (defaulting to vbCrLf).
You can MsgBox this string -- or write it to the immediate window -- or (with a comma chosen as one of the delimiters) -- write it to a CSV file, etc.:
Function MatrixJoin(M As Variant, Optional delim1 As String = vbTab, Optional delim2 As String = vbCrLf) As String
Dim i As Long, j As Long
Dim row As Variant, rows As Variant
ReDim rows(LBound(M, 1) To UBound(M, 1))
ReDim row(LBound(M, 2) To UBound(M, 2))
For i = LBound(M, 1) To UBound(M, 1)
For j = LBound(M, 2) To UBound(M, 2)
row(j) = M(i, j)
Next j
rows(i) = Join(row, delim1)
Next i
MatrixJoin = Join(rows, delim2)
End Function
Tested by:
Sub test()
Dim A As Variant
A = Range("A1:B3").Value
MsgBox MatrixJoin(A)
Debug.Print MatrixJoin(A, ",", ";")
End Sub
Screenshots of output:

Remove the first element of a VBA array

Is there a way to remove the first element of an array in VBA?
Something like javascript shift() method?
Option Explicit
Sub Macro1()
There is no direct method in VBA but you can remove the first element easily like this:
'Your existing code
'...
'Remove "ReDim Preserve matriz(1 To UBound(matriz))"
For i = 1 To UBound(matriz)
matriz(i - 1) = matriz(i)
Next i
ReDim Preserve matriz(UBound(matriz) - 1)
There is unfortunately not. You have to write a method to do it. One good example is http://www.vbforums.com/showthread.php?562928-Remove-Item-from-an-array
'~~> Remove an item from an array, then resize the array
Public Sub DeleteArrayItem(ItemArray As Variant, ByVal ItemElement As Long)
Dim i As Long
If Not IsArray(ItemArray) Then
Err.Raise 13, , "Type Mismatch"
Exit Sub
End If
If ItemElement < LBound(ItemArray) Or ItemElement > UBound(ItemArray) Then
Err.Raise 9, , "Subscript out of Range"
Exit Sub
End If
For i = ItemElement To lTop - 1
ItemArray(i) = ItemArray(i + 1)
Next
On Error GoTo ErrorHandler:
ReDim Preserve ItemArray(LBound(ItemArray) To UBound(ItemArray) - 1)
Exit Sub
ErrorHandler:
'~~> An error will occur if array is fixed
Err.Raise Err.Number, , _
"Array not resizable."
End Sub
If you have a string array, you could join, offset, and split again.
Public Sub test()
Dim vaSplit As Variant
Dim sTemp As String
Const sDEL As String = "||"
vaSplit = Split("1 2 3 4", Space(1))
sTemp = Join(vaSplit, sDEL)
vaSplit = Split(Mid$(sTemp, InStr(1, sTemp, sDEL) + Len(sDEL), Len(sTemp)), sDEL)
Debug.Print Join(vaSplit, vbNewLine)
End Sub
Returns
2
3
4
Not an answer but a study on array addressing.
This code:
ReDim Preserve matriz(1)
matriz(1) = 5
Creates an array with two elements: 0 and 1
UBound() returns 1
Here is some code that may help explore the issue:
Option Explicit
Sub Macro1()
Dim matriz() As Variant
Dim x As Variant
Dim i As Integer
matriz = Array(0)
ReDim Preserve matriz(1)
matriz(1) = 5
ReDim Preserve matriz(2)
matriz(2) = 10
ReDim Preserve matriz(3)
matriz(3) = 4
Debug.Print "Initial For Each"
For Each x In matriz
Debug.Print ":" & x
Next x
Debug.Print "Initial For i = 0"
For i = 0 To UBound(matriz)
Debug.Print ":" & matriz(i)
Next i
Debug.Print "Initial For i = 1"
For i = 1 To UBound(matriz)
Debug.Print ":" & matriz(i)
Next i
Debug.Print "remove one"
For i = 1 To UBound(matriz)
matriz(i - 1) = matriz(i)
Next i
ReDim Preserve matriz(UBound(matriz) - 1)
For Each x In matriz
Debug.Print ":" & x
Next x
Debug.Print "remove one more"
For i = 1 To UBound(matriz)
matriz(i - 1) = matriz(i)
Next i
ReDim Preserve matriz(UBound(matriz) - 1)
For Each x In matriz
Debug.Print ":" & x
Next x
End Sub
Out:
Initial For Each
:0
:5
:10
:4
Initial For i = 0
:0
:5
:10
:4
Initial For i = 1
:5
:10
:4
remove one
:5
:10
:4
remove one more
:10
:4
No direct method, but sort of work around without loops :-)
This approach uses an intermediate target range to
[1] receive the array data (starting e.g. in cell A10) and
.... get them back as resized 2-dim datafield (counting from cell A11 thus omitting the first element) and
[2] transpose it back to a flat 1-dim array
Example code
Option Explicit
Sub Macro1()
'Method: use temporary target range to restructure array
Dim matriz() As Variant
Dim rng As Range
'[0.1] Assign same data set to array as in original post
matriz = Array(0, 5, 10, 4)
Debug.Print "a) original matriz(" & LBound(matriz) & " To " & UBound(matriz) & ")", Join(matriz, ", ")
'instead of:
' ReDim Preserve matriz(0 To 3)
' matriz(0) = 0: matriz(1) = 5: matriz(2) = 10: matriz(3) = 4
'[0.2] Set temporary range to memory
Set rng = ThisWorkbook.Worksheets("Tabelle1").Range("A10").Resize(UBound(matriz) + 1, 1)
'[1] Write array data to range and reassign to matriz cutting first row
rng = Application.Transpose(matriz) ' fill in array data (transposed to column)
matriz = rng.Offset(1, 0).Resize(UBound(matriz), 1) ' assign data to (2-dim) array omitting first row
'[2] Transpose back to flat 1-dim array
matriz = Application.Transpose(Application.Index(matriz, 0, 1))
Debug.Print "b) ~~> new matriz(" & LBound(matriz) & " To " & UBound(matriz) & ")", Join(matriz, ", "),
End Sub
Example output in VBE's immediate window (Debug.Print)
a) original matriz(0 To 3) 0, 5, 10, 4
b) ~~> new matriz(1 To 3) 5, 10, 4
//Edit #1 Tricky alternative using combobox properties & methods
Sub RemoveFirstElement()
'a) Assign same data set to array as in original post
Dim matriz() As Variant
matriz = Array(0, 5, 10, 4)
Debug.Print "a) original matriz (" & LBound(matriz) & " To " & UBound(matriz) & ")", Join(matriz, ", ")
'b) Remove first element in matriz (note 0-based indices!)
RemoveElem matriz, 0 ' << call help procedure RemoveElem
Debug.Print "b) ~~> new matriz (" & LBound(matriz) & " To " & UBound(matriz) & ")", Join(matriz, ", ")
End Sub
Help procedure RemoveElem
This help procedure profits from the integrated method .RemoveItem of a combobox control which you can get on the fly without need to create an extra userform *)
Sub RemoveElem(arr, ByVal elemIndex As Long)
'Use combobox properties and methods on the fly (without need to create form)
With CreateObject("Forms.ComboBox.1")
'a) assign existing values
.List = Application.Transpose(arr)
'b) delete e.g. 1st element (0-based control indices!)
.RemoveItem elemIndex
'c) assign modified values to tmp array (losing 2nd dimension by transposition)
Dim tmp As Variant
tmp = Application.Transpose(.List)
'd) decrement base by 1 (from 1 to 0) - optional
ReDim Preserve tmp(0 To UBound(tmp) - 1)
'e) overwrite original array
arr = tmp
End With
End Sub
Example output in VBE's immediate window (Debug.Print)
a) original matriz(0 To 3) 0, 5, 10, 4
b) ~~> new matriz(1 To 3) 5, 10, 4
Related links
Can I return a 0-based array from ws.UsedRange?
*) I found the way to create a solo combobox at Create an empty 2d-array )
What follows is a function "Shift", which behaves like the shift method in JS, and an example of the use of "Shift"
Sub tryShift()
Dim aRy As Variant, sT As Variant
aRy = Array("one", "two", "three", "four")
Debug.Print "Original array:"
For Each sT In aRy
Debug.Print sT
Next
aRy = Shift(aRy)
Debug.Print vbCrLf & "Array having been " & Chr(34) & "shifted" & Chr(34) & ":"
For Each sT In aRy
Debug.Print sT
Next
End Sub
Function Shift(aRy As Variant)
Dim iCt As Integer, iUbd As Integer
iCt = 0
iUbd = UBound(aRy)
Do While iCt < iUbd
aRy(iCt) = aRy(iCt + 1)
iCt = iCt + 1
Loop
ReDim Preserve aRy(UBound(aRy) - 1)
Shift = aRy
End Function
Output:
Original array:
one
two
three
four
Array having been "shifted":
two
three
four

get entire row of array

I have the following code below,
I want to get the entire row not just column 1 of the original array, how would i do this?
Sub Example1()
Dim arrValues() As Variant
Dim lastRow As Long
Dim filteredArray()
Dim lRow As Long
Dim lCount As Long
Dim tempArray()
lastRow = Sheets("Raw Data").UsedRange.Rows(Sheets("Raw Data").UsedRange.Rows.Count).Row
arrValues = Sheets("Raw Data").Range(Cells(2, 1), Cells(lastRow, 21)).Value
' First use a temporary array with just one dimension
ReDim tempArray(1 To UBound(arrValues))
For lCount = 1 To UBound(arrValues)
If arrValues(lCount, 3) = "phone" Then
lRow = lRow + 1
tempArray(lRow) = arrValues(lCount, 1)
End If
Next
' Now we know how large the filteredArray needs to be: copy the found values into it
ReDim filteredArray(1 To lRow, 1 To 1)
For lCount = 1 To lRow
filteredArray(lCount, 1) = tempArray(lCount)
Next
Sheets("L").Range("A2:U" & 1 + lRow) = filteredArray
End Sub
The ReDim statement can add records on-the-fly with the PRESERVE parameter but only into the last rank. This is a problem as the second rank of a two dimensioned array is typically considered the 'columns' while the first are the 'rows'.
The Application.Transpose can flip rows into columns and vise-versa but it has limitations. (see here and here)
A simple function to transpose without these limitations is actually very easy to build. All you really need are two arrays and two nested loops to flip them.
Sub Example1()
Dim arrVALs() As Variant, arrPHONs() As Variant
Dim v As Long, w As Long
With Sheets("Raw Data").Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, 21).Offset(1, 0)
arrVALs = .Cells.Value
'array dimension check
'Debug.Print LBound(arrVALs, 1) & ":" & UBound(arrVALs, 1)
'Debug.Print LBound(arrVALs, 2) & ":" & UBound(arrVALs, 2)
'Debug.Print Application.CountIf(.Columns(3), "phone") & " phones"
End With
End With
ReDim arrPHONs(1 To UBound(arrVALs, 2), 1 To 1)
For v = LBound(arrVALs, 1) To UBound(arrVALs, 1)
If LCase(arrVALs(v, 3)) = "phone" Then
For w = LBound(arrVALs, 2) To UBound(arrVALs, 2)
arrPHONs(w, UBound(arrPHONs, 2)) = arrVALs(v, w)
Next w
ReDim Preserve arrPHONs(1 To UBound(arrPHONs, 1), _
1 To UBound(arrPHONs, 2) + 1)
End If
Next v
'there is 1 too many in the filtered array
ReDim Preserve arrPHONs(1 To UBound(arrPHONs, 1), _
1 To UBound(arrPHONs, 2) - 1)
'array dimension check
'Debug.Print LBound(arrPHONs, 1) & ":" & UBound(arrPHONs, 1)
'Debug.Print LBound(arrPHONs, 2) & ":" & UBound(arrPHONs, 2)
'Option 1: use built-in Transpose
'Worksheets("L").Range("A2:U" & UBound(arrPHONs, 2) + 1) = Application.Transpose(arrPHONs)
'Option 2: use custom my_2D_Transpose
Worksheets("L").Range("A2:U" & UBound(arrPHONs, 2) + 1) = my_2D_Transpose(arrPHONs)
End Sub
Function my_2D_Transpose(arr As Variant)
Dim a As Long, b As Long, tmp() As Variant
ReDim tmp(1 To UBound(arr, 2), 1 To UBound(arr, 1))
For a = LBound(arr, 1) To UBound(arr, 1)
For b = LBound(arr, 2) To UBound(arr, 2)
tmp(b, a) = Trim(arr(a, b))
Next b
Next a
my_2D_Transpose = tmp
End Function
So if you are in a hurry and the scope of your arrays is such that you will never reach the limits of Application.Transpose then by all means use it. If you cannot safely use transpose then use a custom function.

Resources