Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
need a robust transpose(array) function
I am trying to load an ADO record set to a Listbox on a form.
By using... vadata = rs.GetRows The records set is loaded into a variant array, but I need to transpose the array so my records go left-to-right instead of top-down. I found this gem: Application.WorksheetFunction.Transpose(vaData) but when the record set has more then 255 rows, it gets a type mismatch. I think this is because excel won't handle that many columns. Here is what I have attempted (unsuccessfully): Function Transpose2D(vaData) As Variant 'Transpose the input array swapping rows for columns Dim i As Long, j As Long Dim vaTransposed As Variant ReDim vaTransposed(LBound(vaData, 1) To UBound(vaData, 1), _ LBound(vaData) To UBound(vaData)) As Variant For i = LBound(vaData) To UBound(vaData) For j = LBound(vaData, 1) To UBound(vaData, 1) vaTransposed(j, i) = vaData(i, j) Next j Next i Transpose2D = vaTransposed Set vaTransposed = Nothing End Function vaData is reported as "Variant/Variant(0 to 4, 0 to 807)" but the results of the reDim are (0 to 4, 0 to 4). The function returns the first 5 rows, but the rest are dropped. I seem to recall that ReDim can not handle ReDim'ing multi-dim arrays. How do I get around this ReDim limitation, or is there a better way to transpose large arrays? -- Regards, John |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
need a robust transpose(array) function
The following is a Transpose function; you can judge its robustness for
yourself: Function ArrayTranspose(InputArray) 'This function returns the transpose of 'the input array or range; it is designed 'to avoid the limitation on the number of 'array elements and type of array that the 'worksheet TRANSPOSE Function has. 'Declare the variables Dim outputArrayTranspose As Variant, arr As Variant, p As Integer Dim i As Long, j As Long 'Check to confirm that the input array 'is an array or multicell range If IsArray(InputArray) Then 'If so, convert an input range to a 'true array arr = InputArray 'Load the number of dimensions of 'the input array to a variable On Error Resume Next 'Loop until an error occurs i = 1 Do z = UBound(arr, i) i = i + 1 Loop While Err = 0 'Reset the error value for use with other procedures Err = 0 'Return the number of dimensions p = i - 2 End If If Not IsArray(InputArray) Or p 2 Then Msg = "#ERROR! The function accepts only multi-cell ranges and 1D or 2D arrays." If TypeOf Application.Caller Is Range Then ArrayTranspose = Msg Else MsgBox Msg, 16 End If Exit Function End If 'Load the output array from a one- 'dimensional input array If p = 1 Then Select Case TypeName(arr) Case "Object()" ReDim outputArrayTranspose(LBound(arr) To UBound(arr), LBound(arr) To LBound(arr)) As Object For i = LBound(outputArrayTranspose) To UBound(outputArrayTranspose) Set outputArrayTranspose(i, LBound(outputArrayTranspose)) = arr(i) Next Case "Boolean()" ReDim outputArrayTranspose(LBound(arr) To UBound(arr), LBound(arr) To LBound(arr)) As Boolean Case "Byte()" ReDim outputArrayTranspose(LBound(arr) To UBound(arr), LBound(arr) To LBound(arr)) As Byte Case "Currency()" ReDim outputArrayTranspose(LBound(arr) To UBound(arr), LBound(arr) To LBound(arr)) As Currency Case "Date()" ReDim outputArrayTranspose(LBound(arr) To UBound(arr), LBound(arr) To LBound(arr)) As Date Case "Double()" ReDim outputArrayTranspose(LBound(arr) To UBound(arr), LBound(arr) To LBound(arr)) As Double Case "Integer()" ReDim outputArrayTranspose(LBound(arr) To UBound(arr), LBound(arr) To LBound(arr)) As Integer Case "Long()" ReDim outputArrayTranspose(LBound(arr) To UBound(arr), LBound(arr) To LBound(arr)) As Long Case "Single()" ReDim outputArrayTranspose(LBound(arr) To UBound(arr), LBound(arr) To LBound(arr)) As Single Case "String()" ReDim outputArrayTranspose(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1)) As String Case "Variant()" ReDim outputArrayTranspose(LBound(arr) To UBound(arr), LBound(arr) To LBound(arr)) As Variant Case Else Msg = "#ERROR! Only built-in types of arrays are supported." If TypeOf Application.Caller Is Range Then ArrayTranspose = Msg Else MsgBox Msg, 16 End If Exit Function End Select If TypeName(arr) < "Object()" Then For i = LBound(outputArrayTranspose) To UBound(outputArrayTranspose) outputArrayTranspose(i, LBound(outputArrayTranspose)) = arr(i) Next End If 'Or load the output array from a two- 'dimensional input array or range ElseIf p = 2 Then Select Case TypeName(arr) Case "Object()" ReDim outputArrayTranspose(LBound(arr, 2) To UBound(arr, 2), _ LBound(arr) To UBound(arr)) As Object For i = LBound(outputArrayTranspose) To _ UBound(outputArrayTranspose) For j = LBound(outputArrayTranspose, 2) To _ UBound(outputArrayTranspose, 2) Set outputArrayTranspose(i, j) = arr(j, i) Next Next Case "Boolean()" ReDim outputArrayTranspose(LBound(arr, 2) To UBound(arr, 2), _ LBound(arr) To UBound(arr)) As Boolean Case "Byte()" ReDim outputArrayTranspose(LBound(arr, 2) To UBound(arr, 2), _ LBound(arr) To UBound(arr)) As Byte Case "Currency()" ReDim outputArrayTranspose(LBound(arr, 2) To UBound(arr, 2), _ LBound(arr) To UBound(arr)) As Currency Case "Date()" ReDim outputArrayTranspose(LBound(arr, 2) To UBound(arr, 2), _ LBound(arr) To UBound(arr)) As Date Case "Double()" ReDim outputArrayTranspose(LBound(arr, 2) To UBound(arr, 2), _ LBound(arr) To UBound(arr)) As Double Case "Integer()" ReDim outputArrayTranspose(LBound(arr, 2) To UBound(arr, 2), _ LBound(arr) To UBound(arr)) As Integer Case "Long()" ReDim outputArrayTranspose(LBound(arr, 2) To UBound(arr, 2), _ LBound(arr) To UBound(arr)) As Long Case "Single()" ReDim outputArrayTranspose(LBound(arr, 2) To UBound(arr, 2), _ LBound(arr) To UBound(arr)) As Single Case "String()" ReDim outputArrayTranspose(LBound(arr, 2) To UBound(arr, 2), _ LBound(arr) To UBound(arr)) As String Case "Variant()" ReDim outputArrayTranspose(LBound(arr, 2) To UBound(arr, 2), _ LBound(arr) To UBound(arr)) As Variant Case Else Msg = "#ERROR! Only built-in types of arrays are supported." If TypeOf Application.Caller Is Range Then ArrayTranspose = Msg Else MsgBox Msg, 16 End If Exit Function End Select If TypeName(arr) < "Object()" Then For i = LBound(outputArrayTranspose) To _ UBound(outputArrayTranspose) For j = LBound(outputArrayTranspose, 2) To _ UBound(outputArrayTranspose, 2) outputArrayTranspose(i, j) = arr(j, i) Next Next End If End If 'Return the transposed array ArrayTranspose = outputArrayTranspose End Function |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Transpose array sum | Excel Worksheet Functions | |||
need a robust transpose(array) function | Excel Programming | |||
need a robust transpose(array) function | Excel Programming | |||
Transpose Array | Excel Discussion (Misc queries) | |||
Transpose Function not Working with Long Array Elements | Excel Programming |