'********************************************************************************************************** ' Name: to2DArray ' Author: mielk | 2013-04-26 ' ' Comment: Method to convert the given value (primitive, object or 1D array) into 2D array. ' ' Parameters: ' value Value or array of values to be converted into 2D array. ' ' ' Returns: ' Variant Two-dimensional array containing data given as a parameter. ' * If primitive value or object is given to this function, the result will be ' 2D array with one row and one column and source value inserted as content of ' the only cell of this array. ' * If 1D array is given to this function, the result will be 2D array with one ' column and as many rows as the source array. All the values from the original ' array will be copied into result array. ' * If 2D array is given to this function, the result will be the same array without ' any modification. ' * If dynamic array not initialized yet is given as a parameter, it will be returned ' without any modifications. ' * If any other value is given to this function, exception will be thrown. ' ' ' Exceptions: ' TooManyDimensionsException Thrown if the given parameter is an array having more than two ' dimensions. ' ' --- Changes log ----------------------------------------------------------------------------------------- ' 2013-04-26 mielk Method created. '********************************************************************************************************** Public Function to2DArray(value As Variant) As Variant Const METHOD_NAME As String = "to2DArray" '------------------------------------------------------------------------------------------------------ Dim arr As Variant Dim lngRow As Long Dim lngLBound As Long Dim lngUBound As Long '------------------------------------------------------------------------------------------------------ 'Logic for converting value to 2D array is different for arrays and non-arrays, so first it must ----| 'checked if this value is an array. '| If VBA.IsArray(value) Then '| '| 'Different methods should be invoked for different number of dimensions in original ---------| '| 'array, so the function check how many dimensions has the source array and direct the '| '| 'code into the proper logic. '| '| Select Case countDimensions(value) '| '| '| '| 'Converting 1D array into 2D. -------------------------------------------------------| '| '| Case 1: '| '| '| ReDim arr(1 To 1, 1 To UBound(value) - LBound(value) + 1) '| '| '| lngLBound = LBound(value) '| '| '| lngUBound = UBound(value) '| '| '| '| '| '| '----------------------------------------------------------------------------| '| '| '| For lngRow = lngLBound To lngUBound '| '| '| '| If VBA.IsObject(value(lngRow)) Then '| '| '| '| Set arr(1, lngRow - lngLBound + 1) = value(lngRow) '| '| '| '| Else '| '| '| '| arr(1, lngRow - lngLBound + 1) = value(lngRow) '| '| '| '| End If '| '| '| '| Next lngRow '| '| '| '| '-- [For lngRow = lngLBound To lngUBound] -----------------------------------| '| '| '| '| '| '| '------ [Case 1:] -------------------------------------------------------------------| '| '| '| '| '| '| 'Not-defined arrays (0 dimensions) and 2D arrays should be returned without any -----| '| '| 'modification, so just assign the original value to the variable [arr]. '| '| '| Case 0, 2: arr = value '| '| '| '------ [Case 0, 2:] ----------------------------------------------------------------| '| '| '| '| '| '| 'If original array has more than 2 dimensions, TooManyDimensionsException should ----| '| '| 'be generated. '| '| '| Case Else: GoTo TooManyDimensionsException '| '| '| '------ [Case 0, 2:] ----------------------------------------------------------------| '| '| '| '| End Select '| '| '--------------------------------------------------------------------------------------------| '| '| '| Else '| '| '--- [value] is a single object or a primitive value. ---------------------------------------| '| ReDim arr(1 To 1, 1 To 1) '| '| '| '| 'Before inserting source value into result array , the function must check if it is -----| '| '| 'object or not, because different assigning statement is used in both those cases. '| '| '| If VBA.IsObject(value) Then '| '| '| Set arr(1, 1) = value '| '| '| Else '| '| '| arr(1, 1) = value '| '| '| End If '| '| '| '---------- [If VBA.IsObject(arr(i)) Then] ----------------------------------------------| '| '| '| '| '--------------------------------------------------------------------------------------------| '| '| End If '| '-------------- [If VBA.IsArray(value) Then] --------------------------------------------------------| to2DArray = arr '========================================================================================================== ExitPoint: Exit Function '---------------------------------------------------------------------------------------------------------- TooManyDimensionsException: 'Error handling for the case if the original value is an array having more than 2 dimensions. 'Call Err.Raise(Number:=ERR_DIMENSIONS, Source:=METHOD_NAME, _ Description:="Given array has too many dimensions") GoTo ExitPoint End Function '********************************************************************************************************** ' Name: countDimensions ' Author: mielk | 2012-03-03 ' ' Comment: Returns the number of dimensions of the given VBA array. ' ' Parameters: ' arr Array for which number of dimensions is to be returned. ' ' Returns: ' Integer The number of dimensions of the given VBA array. ' If the given value is not an array function returns -1. ' If the given value is declared as a dynamic array but its dimensions have not been ' declared yet, 0 is returned. ' ' ' --- Changes log ----------------------------------------------------------------------------------------- ' 2012-03-03 mielk Function created. ' 2014-06-15 mielk Returned type changed to Integer to allow -1 to be returned. ' For non-arrays values -1 is returned. '********************************************************************************************************** Public Function countDimensions(arr As Variant) As Integer Const METHOD_NAME As String = "countDimensions" '------------------------------------------------------------------------------------------------------ Dim bound As Long '------------------------------------------------------------------------------------------------------ If VBA.IsArray(arr) Then On Error GoTo NoMoreDimensions Do bound = UBound(arr, countDimensions + 1) countDimensions = countDimensions + 1 Loop Else countDimensions = -1 End If '---------------------------------------------------------------------------------------------------------- NoMoreDimensions: End Function