'********************************************************************************************************** ' Name: removeColumns ' Author: mielk | 2014-09-20 ' ' Description: Function to remove the columns with the specified index from the given array. ' ' Parameters: ' arr Array to be processed. ' It must have two dimensions. If the given array has more or less dimensions, or ' if it is not an array at all, exception will be thrown. ' columnsToBeRemoved Parameter to define which columns should be removed from the source array. ' * It is parameter of ParamArray type, that means it is possible to pass ' custom numbers of values (up to 30) or none values at all. ' * There are two ways to define column to be removed: ' - by giving its index number (it cannot be lower than the minimum column index ' nor greater than the maximum column index in the source array, otherwise it ' will be ignored), ' - by giving header of the column to be removed (if the header fiven by user is ' not found in the source array, it will be ignored). ' * Values of any type other than String or Numeric are ignored. ' ' ' Returns: ' Variant() The source array without the columns defined in [columnsToBeRemoved] parameter. ' ' ' Exceptions: ' NoArrayException Thrown if parameter [arr] is not an array. ' NotDefinedArrayException Thrown if the given array has not been defined yet. ' TooManyDimensionsException Thrown if the given array has more than 2 dimensions. ' ' ' --- Changes log ----------------------------------------------------------------------------------------- ' 2014-09-20 mielk Function created. '********************************************************************************************************** Public Function removeColumns(arr As Variant, ParamArray columnsToBeRemoved() As Variant) As Variant Const METHOD_NAME As String = "removeColumns" '------------------------------------------------------------------------------------------------------ Dim varCol As Variant 'Value to iterate through the param array. Dim dictHeaders As Object 'Dictionary of headers extracted from the source array. Dim dictColumns As Object 'Late binding that allows to use the function, even if 'Microsoft Scripting Runtime library is not loaded. Dim header As String Dim index As Long '------------------------------------------------------------------------------------------------------ Dim columnsCounter As Integer Dim results() As Variant Dim row As Long Dim col As Long Dim resultColumn As Long '------------------------------------------------------------------------------------------------------ 'Check if the given parameter [arr] is the proper array, that can be processed by this function. ----| 'If it is not an array, code is moved to the label NotArrayException. '| 'If it is an array, but has not been initialized yet, code jumps to NotDefinedArrayException label. '| 'If it is an array, but has less or more than two dimensions, code is moved to the label '| 'TooManyDimensionsException. '| If Not VBA.IsArray(arr) Then GoTo NotArrayException '| If Not isDefinedArray(arr) Then GoTo NotDefinedArrayException '| If countDimensions(arr) <> 2 Then GoTo TooManyDimensionsException '| '----------------------------------------------------------------------------------------------------| 'Extract the columns to be removed and put them into Dictionary. ------------------------------------| 'All string values are converted to the index number when the header is found. If there is no '| 'such header in the source array, this value is ignored. '| '| Set dictColumns = VBA.CreateObject("Scripting.Dictionary") '| '| For Each varCol In columnsToBeRemoved '| '| 'Check if the current value is numeric. All non-numeric values are considered to be ---------| '| 'column header and function should find its index in the source array. '| '| If VBA.IsNumeric(varCol) Then '| '| '| '| 'For column defined by index, function needs to check if they don't exceed ----------| '| '| 'array columns range. '| '| '| If varCol >= LBound(arr, 1) And varCol <= UBound(arr, 1) Then '| '| '| '| '| '| index = VBA.CLng(varCol) '| '| '| '| '| '| End If '| '| '| '------- [If varCol >= LBound(arr, 1) And varCol <= UBound(arr, 1) Then] ------------| '| '| '| '| Else '| '| '| '| header = stringify(varCol) '| '| '| '| '| '| 'Only non empty headers are being searched in the source array. ---------------------| '| '| If isNonEmptyString(header) Then '| '| '| '| '| '| 'Extracting source array headers is initialized only when the first --------| '| '| '| 'non-numeric item is found. There is no point to do that, if there are '| '| '| '| 'only numeric column index given in the parameter. '| '| '| '| If dictHeaders Is Nothing Then '| '| '| '| Set dictHeaders = getArrayHeadersAsDictionary(arr) '| '| '| '| End If '| '| '| '| '----------------------------------------------------------------------------| '| '| '| '| '| '| '| '| '| 'Check if there is such header in the source array. -------------------------| '| '| '| With dictHeaders '| '| '| '| If .Exists(header) Then '| '| '| '| index = .item(header) '| '| '| '| End If '| '| '| '| End With '| '| '| '| '----------------------------------------------------------------------------| '| '| '| '| '| '| '| '| '| End If '| '| '| '------------------------------------------------------------------------------------| '| '| '| '| '| '| End If '| '| '----------- [If VBA.IsNumeric(varCol) Then] ------------------------------------------------| '| '| '| 'Add the index to the dictionary of columns to be removed. ----------------------------------| '| With dictColumns '| '| If Not .Exists(index) Then '| '| Call .add(index, index) '| '| End If '| '| End With '| '| '--- [With dictColumns] ---------------------------------------------------------------------| '| '| '| Next varCol '| '--------------- [For Each varCol In columnsToBeRemoved] --------------------------------------------| 'Resize the final array to the proper size. ---------------------------------------------------------| columnsCounter = arraySize(arr, 1) - dictColumns.Count '| '| 'If all the columns are selected to be removed, empty array is returned. ------------------------| '| If columnsCounter = 0 Then GoTo RemoveAllColumns '| '| '------------------------------------------------------------------------------------------------| '| '| ReDim results(1 To columnsCounter, LBound(arr, 2) To UBound(arr, 2)) '| '----------------------------------------------------------------------------------------------------| 'Iterate through all the columns from the original array and append to the final array those --------| 'columns that are not selected to be removed. '| For col = LBound(arr, 1) To UBound(arr, 1) '| '| 'Check if this column exists in the dictionary of column to be removed. If not, append ------| '| 'data from this column to the final array. '| '| If Not dictColumns.Exists(col) Then '| '| '| '| resultColumn = resultColumn + 1 '| '| '| '| 'Iterate through all the cells in this column, and append their values to the -------| '| '| 'final array. '| '| '| For row = LBound(arr, 2) To UBound(arr, 2) '| '| '| '| '| '| 'Before adding value to the array, it has to be checked if the value is -----| '| '| '| 'an object or a primitive value, because there is a difference in '| '| '| '| 'syntex when appending objects and non-objects. '| '| '| '| If VBA.IsObject(arr(col, row)) Then '| '| '| '| Set results(resultColumn, row) = arr(col, row) '| '| '| '| Else '| '| '| '| results(resultColumn, row) = arr(col, row) '| '| '| '| End If '| '| '| '| '-------------- [If VBA.IsObject(value) Then] -------------------------------| '| '| '| '| '| '| Next row '| '| '| '------------------ [For row = LBound(arr, 2) To UBound(arr, 2)] --------------------| '| '| '| '| End If '| '| '---------------------- [If Not dictColumns.Exists(col) Then] -------------------------------| '| '| Next col '| '-------------------------- [For col = LBound(arr, 1) To UBound(arr, 1)] ----------------------------| '========================================================================================================== ExitPoint: 'Assign final array to the result of this function. removeColumns = results Exit Function '---------------------------------------------------------------------------------------------------------- NotArrayException: 'Error handling for the case if the given parameter [arr] is not an array. GoTo ExitPoint NotDefinedArrayException: 'Error handling for the case if the given parameter [arr] is an array but it has not been 'initialized yet. GoTo ExitPoint TooManyDimensionsException: 'Error-handling for case if the given parameter is an array but it has more than 2 dimensions. GoTo ExitPoint RemoveAllColumns: GoTo ExitPoint End Function '********************************************************************************************************** ' Name: isDefinedArray ' Author: mielk | 2012-03-27 ' ' Description: Function to check if the given parameter is an array with dimensions and sizes already ' declared. ' ' Parameters: ' arr Parameter to be tested. ' ' Returns: ' Boolean True - if parameter [arr] is an array and its dimensions and sizes has been already ' defined. ' False - if parameter [arr] is not an array or it is declared as a dynamic array but its ' dimension and size have not been defined yet. ' ' --- Changes log ----------------------------------------------------------------------------------------- ' 2012-03-27 mielk Function created. ' 2014-08-10 mielk Case about arrays with negative up bound instead of being not declared. '********************************************************************************************************** Public Function isDefinedArray(arr As Variant) As Boolean Const METHOD_NAME As String = "isDefinedArray" '------------------------------------------------------------------------------------------------------ Dim upBound As Long Dim lowBound As Long '------------------------------------------------------------------------------------------------------ 'Try to assign bottom and top bound of the given parameter. 'If it is not an array or is not declared yet, code will move to 'the label NotArrayException and function will return False. On Error GoTo NotArrayException upBound = UBound(arr, 1) lowBound = LBound(arr, 1) 'In some cases, it is possible to get LBound and UBound of a dynamic array 'althought it is not declared yet (i.e. arrays returned as a result of VBA 'built-in Split function if empty string is passed as a parameter), 'however in this case UBound will be lower than LBound. isDefinedArray = (upBound >= lowBound) '========================================================================================================== ExitPoint: Exit Function '---------------------------------------------------------------------------------------------------------- NotArrayException: 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 '********************************************************************************************************** ' Name: stringify ' Author: mielk | 2014-09-20 ' ' Description: Function to convert the given parameter into String. ' This function works similar to VBA built-in function VBA.CStr but it doesn't throw ' an error if value passed as a input parameter cannot be converted to String. ' ' ' Parameters: ' value Value to be converted into String. ' ' ' Returns: ' String The string representation of the given parameter. ' * For primitives value, function returns the same value as VBA built-in function ' VBA.CStr. ' * For arrays, function returns all its values converted to String. ' * For object, function check if it contains function toString and returns its ' result. If there is no such method for this object, value defined in OBJECT_TAG ' constant is returned. ' ' ' ' --- Changes log ----------------------------------------------------------------------------------------- ' 2014-09-20 mielk Function created. '********************************************************************************************************** Public Function stringify(value As Variant) As String Const METHOD_NAME As String = "stringify" '------------------------------------------------------------------------------------------------------ Const OBJECT_TAG = "[Object]" '------------------------------------------------------------------------------------------------------ On Error Resume Next 'For missing and empty parameters, empty String is returned. ----------------------------------------| If Not VBA.IsMissing(value) And Not VBA.isEmpty(value) Then '| '| 'There is different logic for obtaining String representation of object and -----------------| '| 'primitive value, so function needs to check which one is the given parameter. '| '| If VBA.IsObject(value) Then '| '| stringify = value.toString '| '| If VBA.Len(stringify) = 0 Then stringify = OBJECT_TAG '| '| Else '| '| stringify = VBA.CStr(value) '| '| End If '| '| '--------------------------------------------------------------------------------------------| '| '| End If '| '----------------------------------------------------------------------------------------------------| End Function '********************************************************************************************************** ' Name: isNonEmptyString ' Author: mielk | 2014-09-20 ' ' Description: Function to check if the given value is a non-empty string. ' Note that strings consisting only of blank characters (i.e. spaces) are also ' considered to be an empty string. ' ' Parameters: ' value Value to be checked. ' ' ' Returns: ' Boolean True is returned only if the given value or its text representation is a non-empty ' string. ' False value is returned in a few cases: ' * the source parameter [value] is an empty string, ' * the source parameter [value] is a string consisting only of blank characters, ' * the source parameter [value] is not a string and cannot be converted into ' string (i.e it is object or array). ' ' ' ' --- Changes log ----------------------------------------------------------------------------------------- ' 2014-09-20 mielk Function created. '********************************************************************************************************** Public Function isNonEmptyString(ByVal value As Variant) As Boolean Const METHOD_NAME As String = "isNonEmptyString" '------------------------------------------------------------------------------------------------------ If Not VBA.IsObject(value) Then isNonEmptyString = VBA.Len(removeSpaces(stringify(value))) > 0 End If End Function '********************************************************************************************************** ' Name: removeSpaces ' Author: mielk | 2012-11-18 ' ' Comment: Function to remove all the blank characters from the given string. ' ' Parameters: ' text String to be cleaned of blank characters. ' The given value must be of a String type or of any other type that can be ' converted to String. ' The following characters are considered by this function as blank: ' ' Character | ASCII code ' ------------------------|-------------- ' Horizontal Tab | 9 ' Line Feed | 10 ' Carriage Return | 13 ' Space | 32 ' No-Break Space | 160 ' ' Returns: ' String The original text cleaned of blank characters. ' ' ' --- Changes log ----------------------------------------------------------------------------------------- ' 2012-11-18 mielk Function created. '********************************************************************************************************** Public Function removeSpaces(ByVal text As String) As String Const METHOD_NAME As String = "removeSpaces" '------------------------------------------------------------------------------------------------------ removeSpaces = VBA.Replace(text, VBA.Chr$(9), "") '..........................tab removeSpaces = VBA.Replace(removeSpaces, VBA.Chr$(10), "") '.................... linefeed removeSpaces = VBA.Replace(removeSpaces, VBA.Chr$(13), "") '.................... carriage removeSpaces = VBA.Replace(removeSpaces, VBA.Chr$(32), "") '....................... space removeSpaces = VBA.Replace(removeSpaces, VBA.Chr$(160), "") '....................... space End Function '********************************************************************************************************** ' Name: getArrayHeadersAsDictionary ' Author: mielk | 2014-09-20 ' ' Description: Function to create a dictionary with mapping of the given array's columns. ' Column header text is the key in the result dictionary and its index number is ' the value. ' ' Parameters: ' arr Array which columns are to be returned. ' It must have two dimensions, it the given array has more or less dimensions, or ' if it is not an array at all, exception will be thrown. ' ' ' Returns: ' Dictionary Dictionary with map of the given array's columns. ' As a key column headers texts are used, and their column index numbers are used ' as a value. ' ' ' Exceptions: ' NoArrayException Thrown if parameter [arr] is not an array. ' NotDefinedArrayException Thrown if the given array has not been defined yet. ' TooManyDimensionsException Thrown if the given array has more than 2 dimensions. ' ' ' --- Changes log ----------------------------------------------------------------------------------------- ' 2014-09-20 mielk Function created. '********************************************************************************************************** Public Function getArrayHeadersAsDictionary(arr As Variant) As Object Const METHOD_NAME As String = "getArrayHeadersAsDictionary" '------------------------------------------------------------------------------------------------------ Dim column As Long '------------------------------------------------------------------------------------------------------ 'Check if the given parameter [arr] is an array, if it has been already initialized and -------------| 'if it has exactly two dimensions. '| 'If it is not an array, code is moved to the label NotArrayException. '| 'If it is an array, but has not been initialized yet, code is moved to the label '| 'NotDefinedArrayException. '| 'If it is an array, but has less or more than two dimensions, code is moved to the label '| 'TooManyDimensionsException. '| If Not VBA.IsArray(arr) Then GoTo NotArrayException '| If Not isDefinedArray(arr) Then GoTo NotDefinedArrayException '| If countDimensions(arr) <> 2 Then GoTo TooManyDimensionsException '| '----------------------------------------------------------------------------------------------------| 'Create new instance of Dictionary and set it searching mode as case insensitive. -------------------| Set getArrayHeadersAsDictionary = VBA.CreateObject("Scripting.Dictionary") '| getArrayHeadersAsDictionary.CompareMode = TextCompare '| '----------------------------------------------------------------------------------------------------| 'Iterate through all the columns in the given array and put their names and index numbers to --------| 'the final Dictionary. '| For column = LBound(arr, 1) To UBound(arr, 1) '| With getArrayHeadersAsDictionary '| If Not .Exists(arr(column, 1)) Then '| Call .add(arr(column, 1), column) '| End If '| End With '| Next column '| '----------------------------------------------------------------------------------------------------| '========================================================================================================== ExitPoint: Exit Function '---------------------------------------------------------------------------------------------------------- NotArrayException: 'Error handling for the case if the given parameter [arr] is not an array. GoTo ExitPoint NotDefinedArrayException: 'Error handling for the case if the given parameter [arr] is an array but it has not been 'initialized yet. GoTo ExitPoint TooManyDimensionsException: 'Error-handling for case if the given parameter is an array but it has more than 2 dimensions. GoTo ExitPoint End Function '********************************************************************************************************** ' Name: arraySize ' Author: mielk | 2014-07-15 ' ' Comment: Function returns the size of the specified dimension of the given array. ' ' Parameters: ' arr Array which size is to be returned. ' dimension Dimension for which the size is to be returned. ' This parameter is optional. If it is skipped, the size of first dimension will ' be returned. ' ' ' Returns: ' Long Size of the given array in the specified dimension. ' ' Examples: ' ----------------------------------------------------------------------------------- ' ' ' ' Exceptions: ' NotArrayException Thrown if the given parameter [arr] is not an array. ' NotDefinedArrayException Thrown if the given paremeter [arr] is an array, but it has not been ' initialized yet. ' IndexOutOfBoundException Thrown if the parameter [dimension] exceeds the number of dimensions ' in the given base array [arr]. ' ' ' --- Changes log ----------------------------------------------------------------------------------------- ' 2014-07-15 mielk Method created. '********************************************************************************************************** Public Function arraySize(arr As Variant, Optional dimension As Integer = 1) As Long Const METHOD_NAME As String = "arraySize" '------------------------------------------------------------------------------------------------------ 'Check if the given parameter [arr] is an array and if it has been already initialized. -------------| 'If it is not an array, code is moved to the label NotArrayException. '| 'If it is an array, but has not been initialized yet, code is moved to the label '| 'NotDefinedArrayException. '| If Not VBA.IsArray(arr) Then GoTo NotArrayException '| If Not isDefinedArray(arr) Then GoTo NotDefinedArrayException '| '----------------------------------------------------------------------------------------------------| 'Compare parameter [dimension] with the number of dimensions in the given array [arr]. If it is -----| 'greater than the number of dimensions, IndexOutOfBoundException is thrown. '| If dimension > countDimensions(arr) Then GoTo IndexOutOfBoundException '| '----------------------------------------------------------------------------------------------------| 'Calculate the size of the given array in the given dimension. --------------------------------------| arraySize = UBound(arr, dimension) - LBound(arr, dimension) + 1 '| '----------------------------------------------------------------------------------------------------| '========================================================================================================== ExitPoint: Exit Function '---------------------------------------------------------------------------------------------------------- NotArrayException: 'Error handling for the case if the given parameter [arr] is not an array. GoTo ExitPoint NotDefinedArrayException: 'Error handling for the case if the given parameter [arr] is an array but it has not been 'initialized yet. GoTo ExitPoint IndexOutOfBoundException: 'Error handling for the case if the given dimension exceeds the number of dimensions in the given 'array [arr] GoTo ExitPoint End Function