The typical way to accomplish the above diseminated in these newsgroups
has been
myArray2 = Application.Transpose(Application.Transpose(myArray1))
Less typical, but equally effective, is
myArray2 = Application.Index(myArray1, 1, 0)
Both of these methods have the following limitations: they don't work on
large arrays (i.e., arrays of more than 65536 elements in Excel2007;
arrays of much fewer elements in earlier versions); and they both
produce a myArray2 of the Variant() type, even if myArray1 is of a
different built-in type.
The following function avoids those limitations (watch for wordwrap). It
invokes the function ArrayDimensions, which is freely downloadable with
the file at
http://home.pacbell.net/beban, and which is also included
below for convenience.
Function ChangeToOneD(inputArray)
If Not IsArray(inputArray) Then
GoTo ErrMsg
ElseIf TypeOf inputArray Is Range Then
GoTo ErrMsg
ElseIf ArrayDimensions(inputArray) <> 2 Or UBound(inputArray) > 1 Then
GoTo ErrMsg
Else
Dim arrOut
x = TypeName(inputArray)
If x = "Object()" Then
ReDim arrOut(LBound(inputArray,2) To UBound(inputArray,2))
As Object
For i = LBound(inputArray, 2) To UBound(inputArray, 2)
Set arrOut(i) = inputArray(1, i)
Next
ChangeToOneD = arrOut
Exit Function
End If
Select Case x
Case "Boolean()"
ReDim arrOut(LBound(inputArray, 2) To
UBound(inputArray, 2)) As Boolean
Case "Byte()"
ReDim arrOut(LBound(inputArray, 2) To
UBound(inputArray, 2)) As Byte
Case "Currency()"
ReDim arrOut(LBound(inputArray, 2) To
UBound(inputArray, 2)) As Currency
Case "Date()"
ReDim arrOut(LBound(inputArray, 2) To
UBound(inputArray, 2)) As Date
Case "Double()"
ReDim arrOut(LBound(inputArray, 2) To
UBound(inputArray, 2)) As Double
Case "Integer()"
ReDim arrOut(LBound(inputArray, 2) To
UBound(inputArray, 2)) As Integer
Case "Long()"
ReDim arrOut(LBound(inputArray, 2) To
UBound(inputArray, 2)) As Long
Case "Single()"
ReDim arrOut(LBound(inputArray, 2) To
UBound(inputArray, 2)) As Single
Case "String()"
ReDim arrOut(LBound(inputArray, 2) To
UBound(inputArray, 2)) As String
Case "Variant()"
ReDim arrOut(LBound(inputArray, 2) To
UBound(inputArray, 2)) As Variant
Case Else
GoTo ErrMsg
End Select
For i = LBound(inputArray, 2) To UBound(inputArray, 2)
arrOut(i) = inputArray(1, i)
Next
ChangeToOneD = arrOut
End If
Exit Function
ErrMsg: Msg = "The function accepts only 2-dimensional, single row VBA
arrays of a built-in type."
MsgBox Msg, 16
End Function
Function ArrayDimensions(InputArray As Variant)
'This function returns the number of dimensions
'of the input array. It contains a loop that was
'suggested in the .programming group by Dana DeLouis.
'Declare variables
Dim arr1, i As Integer, z As Long
If Not TypeName(InputArray) Like "*()" Then
Msg = "#ERROR! The function accepts only arrays."
If TypeOf Application.Caller Is Range Then
ArrayDimensions = Msg
Else
MsgBox Msg, 16
End If
Exit Function
End If
On Error Resume Next
'Loop until an error occurs
i = 1
Do
z = UBound(InputArray, i)
i = i + 1
Loop While Err = 0
'Reset the error value for use with other procedures
Err = 0
'Return the number of dimensions
ArrayDimensions = i - 2
End Function
Alan Beban
Similar Threads
