├── .gitattributes ├── .github └── FUNDING.yml ├── LICENSE ├── README.md ├── VBA ArrayTools_DEMO.xlsm └── src ├── Demo └── DEMO.bas ├── LibArrayTools.bas ├── Test ├── TestLibArrayTools.bas ├── frmTestResults.frm └── frmTestResults.frx └── UDF_DataManipulation.bas /.gitattributes: -------------------------------------------------------------------------------- 1 | *.bas eol=crlf 2 | *.cls eol=crlf -------------------------------------------------------------------------------- /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | github: cristianbuse 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Ion Cristian Buse 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # VBA-ArrayTools 2 | 3 | ArrayTools is a Project that allows easy data manipulation when working with Arrays and Collections in VBA (regardless of host Application). Operations like sorting, filtering, converting, reversing, slicing are trivial using the LibArrayTools module. Additionaly, a User-Defined-Function (UDF) module is available for Microsoft Excel. 4 | 5 | ## Installation 6 | 7 | Just import the following code modules in your VBA Project: 8 | 9 | * **LibArrayTools.bas** 10 | * **UDF_DataManipulation.bas** (optional - works in MS Excel interface only, with exposed User Defined Functions) 11 | 12 | ## Testing 13 | 14 | Import the folowing code modules: 15 | * **TestLibArrayTools.bas** 16 | * **frmTestResults.frm** 17 | 18 | and execute method: 19 | ```vba 20 | TestLibArrayTools.RunAllTests 21 | ``` 22 | 23 | ## Usage 24 | Here are a couple of demo method calls. Find more in the available Demo.bas module 25 | 26 | Array-Array conversions, Array-Collection conversions (and viceversa). Note that methods like 'NDArrayTo1DArray' support arrays up to 60 dimensions. 27 | ```vba 28 | Public Sub DemoConversions() 29 | Dim coll As Collection 30 | ' 31 | 'Create a Collection from values 32 | Set coll = Collection(1, 2, 3, 4, 5) 33 | 'Result: 34 | ' [1,2,3,4,5] 35 | ' 36 | Dim arr() As Variant 37 | ' 38 | 'Convert a Collection to a 1D Array 39 | arr = CollectionTo1DArray(coll) 40 | 'Result: 41 | ' [1,2,3,4,5,6] 42 | ' 43 | 'Convert a Collection to a 2D Array 44 | arr = CollectionTo2DArray(coll, 3) 45 | 'Result: 46 | ' [1,2,3] 47 | ' [4,5,6] 48 | ' 49 | 'Convert 1D Array to a 2D Array 50 | arr = OneDArrayTo2DArray(Array(5, 2, 1, 3, 6, 1, 9, 5), 2) 51 | 'Result: 52 | ' [5,2] 53 | ' [1,3] 54 | ' [6,1] 55 | ' [9,5] 56 | ' 57 | arr = OneDArrayTo2DArray(Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12), 4) 58 | Dim arr2() As Variant 59 | ' 60 | 'Convert 2D Array to 1D Array 61 | arr2 = NDArrayTo1DArray(arr, rowWise) 62 | 'Result: 63 | ' [1,2,3,4,5,6,7,8,9,10,11,12] 64 | arr2 = NDArrayTo1DArray(arr, columnWise) 65 | 'Result: 66 | ' [1,5,9,2,6,10,3,7,11,4,8,12] 67 | ' 68 | 'Convert 2D Array to nested Collections 69 | Set coll = NDArrayToCollections(arr) 70 | 'Result: 71 | ' [[1,2,3,4],[5,6,7,8],[9,10,11,12]] 72 | ' 73 | 'Merge two 1D arrays 74 | arr = Merge1DArrays(Array(1, 2, 3), Array(4, 5)) 75 | 'Result: 76 | ' [1,2,3,4,5] 77 | ' 78 | Dim arr1() As Variant 79 | arr1 = OneDArrayTo2DArray(Array(1, 2, 3, 4), 2) 80 | arr2 = OneDArrayTo2DArray(Array(5, 6, 7, 8), 2) 81 | 82 | 'Merge two 2D arrays 83 | arr = Merge2DArrays(arr1, arr2, False) 84 | 'Result: 85 | ' [1,2,5,6] 86 | ' [3,4,7,8] 87 | arr = Merge2DArrays(arr1, arr2, True) 88 | 'Result: 89 | ' [1,2] 90 | ' [3,4] 91 | ' [5,6] 92 | ' [7,8] 93 | ' 94 | 'Transpose a 2D Array 95 | arr = TransposeArray(arr1) 96 | 'Result: 97 | ' [1,3] 98 | ' [2,4] 99 | End Sub 100 | ``` 101 | Array and Collection advanced Filtering 102 | ```vba 103 | Public Sub DemoFiltering() 104 | Dim arr() As Variant 105 | Dim coll As Collection 106 | Dim filters() As FILTER_PAIR 107 | Dim boolExpression As Boolean 108 | ' 109 | 'Check if a value is passing a filter 110 | boolExpression = IsValuePassingFilter(5, CreateFilter(opBigger, 3)) 'True 111 | boolExpression = IsValuePassingFilter(5, CreateFilter(opBigger, 7)) 'False 112 | boolExpression = IsValuePassingFilter(5, CreateFilter(opin, Array(1, 3, 5))) 'True 113 | boolExpression = IsValuePassingFilter("test", CreateFilter(opLike, "?es?")) 'True 114 | boolExpression = IsValuePassingFilter("c", CreateFilter(opLike, "[a-d]")) 'True 115 | ' 116 | 'Create array of filters 117 | filters = CreateFiltersArray(">", 1, "<=", 5, "NOT IN", Array(3, 4)) 118 | ' 119 | 'Filter a 1D Array 120 | arr = Filter1DArray(Array(1, 2, 3, 4, 5), filters) 121 | 'Result: 122 | ' [2,5] 123 | ' 124 | arr = OneDArrayTo2DArray(Array(5, 2, 1, 3, 6, 1, 9, 5), 2) 125 | filters = CreateFiltersArray("IN", Array(1, 3, 5, 7, 9)) 126 | ' 127 | 'Filter a 2D Array 128 | arr = Filter2DArray(arr, 0, filters) 129 | 'Result: 130 | ' [5,2] 131 | ' [1,3] 132 | ' [9,5] 133 | arr = Filter2DArray(arr, 1, filters) 134 | 'Result: 135 | ' [1,3] 136 | ' [9,5] 137 | ' 138 | 'Filter a Collection 139 | Set coll = FilterCollection(Collection("A", "B", "C", "D", "E") _ 140 | , CreateFiltersArray("LIKE", "[B-E]", "NOT LIKE", "[C-D]")) 141 | 'Result: 142 | ' ["B","E"] 143 | End Sub 144 | ``` 145 | Information functions related to Arrays/Collections 146 | ```vba 147 | Public Sub DemoGetInformation() 148 | Dim coll As New Collection 149 | Dim boolExpression As Boolean 150 | ' 151 | coll.Add 6, "Key1" 152 | ' 153 | 'Check if a Collection has a key 154 | boolExpression = CollectionHasKey(coll, "Key1") 'True 155 | boolExpression = CollectionHasKey(coll, "Key2") 'False 156 | ' 157 | Dim arr() As Variant 158 | Dim arr2D(0 To 2, 0 To 3) As Variant 159 | Dim arr3D(1 To 3, 1 To 2, 1 To 5) As Variant 160 | Dim arr4D(1 To 2, 1 To 3, 1 To 4, 1 To 5) As Variant 161 | Dim dimensionsCount As Long 162 | Dim elementsCount As Long 163 | ' 164 | 'Get the number of dimensions for an array 165 | dimensionsCount = GetArrayDimsCount(7) '0 166 | dimensionsCount = GetArrayDimsCount(arr) '0 167 | dimensionsCount = GetArrayDimsCount(Array()) '1 168 | dimensionsCount = GetArrayDimsCount(arr2D) '2 169 | dimensionsCount = GetArrayDimsCount(arr3D) '3 170 | dimensionsCount = GetArrayDimsCount(arr4D) '4 171 | ' 172 | 'Get the number of elements for an array 173 | elementsCount = GetArrayElemCount(5) '0 174 | elementsCount = GetArrayElemCount(arr) '0 175 | elementsCount = GetArrayElemCount(Array(1, 5, 6)) '3 176 | elementsCount = GetArrayElemCount(arr2D) '12 177 | elementsCount = GetArrayElemCount(arr3D) '30 178 | elementsCount = GetArrayElemCount(arr4D) '120 179 | ' 180 | 'Check if a variant support For...Each loop 181 | boolExpression = IsIterable(arr) 'False 182 | boolExpression = IsIterable(Array()) 'True 183 | boolExpression = IsIterable(coll) 'True 184 | boolExpression = IsIterable(Nothing) 'False 185 | End Sub 186 | ``` 187 | 188 | ## Notes 189 | * Argument Descriptions in the Function Help for the Excel Function Arguments Dialog (fx on the formula bar or Shift + F3) are available by running: 190 | ```vba 191 | UDF_DataManipulation.RegisterDMFunctions 192 | ``` 193 | * Download the available Demo Workbook. Each UDF is presented with examples in a separate worksheet. 194 | 195 | ## License 196 | MIT License 197 | 198 | Copyright (c) 2012 Ion Cristian Buse 199 | 200 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 201 | 202 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 203 | 204 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /VBA ArrayTools_DEMO.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cristianbuse/VBA-ArrayTools/146b016961c32ad0e301349edd23e7df43243b98/VBA ArrayTools_DEMO.xlsm -------------------------------------------------------------------------------- /src/Demo/DEMO.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "DEMO" 2 | '''============================================================================= 3 | ''' VBA ArrayTools 4 | '''----------------------------------------------- 5 | ''' https://github.com/cristianbuse/VBA-ArrayTools 6 | '''----------------------------------------------- 7 | ''' 8 | ''' Copyright (c) 2012 Ion Cristian Buse 9 | ''' 10 | ''' Permission is hereby granted, free of charge, to any person obtaining a copy 11 | ''' of this software and associated documentation files (the "Software"), to deal 12 | ''' in the Software without restriction, including without limitation the rights 13 | ''' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 14 | ''' copies of the Software, and to permit persons to whom the Software is 15 | ''' furnished to do so, subject to the following conditions: 16 | ''' 17 | ''' The above copyright notice and this permission notice shall be included in all 18 | ''' copies or substantial portions of the Software. 19 | ''' 20 | ''' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 21 | ''' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 22 | ''' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 23 | ''' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 24 | ''' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 25 | ''' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 26 | ''' SOFTWARE. 27 | '''============================================================================= 28 | 29 | Option Explicit 30 | 31 | Public Sub DemoConversions() 32 | Dim coll As Collection 33 | ' 34 | 'Create a Collection from values 35 | Set coll = Collection(1, 2, 3, 4, 5) 36 | 'Result: 37 | ' [1,2,3,4,5] 38 | ' 39 | Dim arr() As Variant 40 | ' 41 | 'Convert a Collection to a 1D Array 42 | arr = CollectionTo1DArray(coll) 43 | 'Result: 44 | ' [1,2,3,4,5,6] 45 | ' 46 | 'Convert a Collection to a 2D Array 47 | arr = CollectionTo2DArray(coll, 3) 48 | 'Result: 49 | ' [1,2,3] 50 | ' [4,5,6] 51 | ' 52 | 'Convert 1D Array to a 2D Array 53 | arr = OneDArrayTo2DArray(Array(5, 2, 1, 3, 6, 1, 9, 5), 2) 54 | 'Result: 55 | ' [5,2] 56 | ' [1,3] 57 | ' [6,1] 58 | ' [9,5] 59 | ' 60 | arr = OneDArrayTo2DArray(Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12), 4) 61 | Dim arr2() As Variant 62 | ' 63 | 'Convert 2D Array to 1D Array 64 | arr2 = NDArrayTo1DArray(arr, rowWise) 65 | 'Result: 66 | ' [1,2,3,4,5,6,7,8,9,10,11,12] 67 | arr2 = NDArrayTo1DArray(arr, columnWise) 68 | 'Result: 69 | ' [1,5,9,2,6,10,3,7,11,4,8,12] 70 | ' 71 | 'Convert 2D Array to nested Collections 72 | Set coll = NDArrayToCollections(arr) 73 | 'Result: 74 | ' [[1,2,3,4],[5,6,7,8],[9,10,11,12]] 75 | ' 76 | 'Merge two 1D arrays 77 | arr = Merge1DArrays(Array(1, 2, 3), Array(4, 5)) 78 | 'Result: 79 | ' [1,2,3,4,5] 80 | ' 81 | Dim arr1() As Variant 82 | arr1 = OneDArrayTo2DArray(Array(1, 2, 3, 4), 2) 83 | arr2 = OneDArrayTo2DArray(Array(5, 6, 7, 8), 2) 84 | 85 | 'Merge two 2D arrays 86 | arr = Merge2DArrays(arr1, arr2, False) 87 | 'Result: 88 | ' [1,2,5,6] 89 | ' [3,4,7,8] 90 | arr = Merge2DArrays(arr1, arr2, True) 91 | 'Result: 92 | ' [1,2] 93 | ' [3,4] 94 | ' [5,6] 95 | ' [7,8] 96 | ' 97 | 'Transpose a 2D Array 98 | arr = TransposeArray(arr1) 99 | 'Result: 100 | ' [1,3] 101 | ' [2,4] 102 | End Sub 103 | 104 | Public Sub DemoFiltering() 105 | Dim arr() As Variant 106 | Dim coll As Collection 107 | Dim filters() As FILTER_PAIR 108 | Dim boolExpression As Boolean 109 | ' 110 | 'Check if a value is passing a filter 111 | boolExpression = IsValuePassingFilter(5, CreateFilter(opBigger, 3)) 'True 112 | boolExpression = IsValuePassingFilter(5, CreateFilter(opBigger, 7)) 'False 113 | boolExpression = IsValuePassingFilter(5, CreateFilter(opin, Array(1, 3, 5))) 'True 114 | boolExpression = IsValuePassingFilter("test", CreateFilter(opLike, "?es?")) 'True 115 | boolExpression = IsValuePassingFilter("c", CreateFilter(opLike, "[a-d]")) 'True 116 | ' 117 | 'Create array of filters 118 | filters = CreateFiltersArray(">", 1, "<=", 5, "NOT IN", Array(3, 4)) 119 | ' 120 | 'Filter a 1D Array 121 | arr = Filter1DArray(Array(1, 2, 3, 4, 5), filters) 122 | 'Result: 123 | ' [2,5] 124 | ' 125 | arr = OneDArrayTo2DArray(Array(5, 2, 1, 3, 6, 1, 9, 5), 2) 126 | filters = CreateFiltersArray("IN", Array(1, 3, 5, 7, 9)) 127 | ' 128 | 'Filter a 2D Array 129 | arr = Filter2DArray(arr, 0, filters) 130 | 'Result: 131 | ' [5,2] 132 | ' [1,3] 133 | ' [9,5] 134 | arr = Filter2DArray(arr, 1, filters) 135 | 'Result: 136 | ' [1,3] 137 | ' [9,5] 138 | ' 139 | 'Filter a Collection 140 | Set coll = FilterCollection(Collection("A", "B", "C", "D", "E") _ 141 | , CreateFiltersArray("LIKE", "[B-E]", "NOT LIKE", "[C-D]")) 142 | 'Result: 143 | ' ["B","E"] 144 | End Sub 145 | 146 | Public Sub DemoGetInformation() 147 | Dim coll As New Collection 148 | Dim boolExpression As Boolean 149 | ' 150 | coll.Add 6, "Key1" 151 | ' 152 | 'Check if a Collection has a key 153 | boolExpression = CollectionHasKey(coll, "Key1") 'True 154 | boolExpression = CollectionHasKey(coll, "Key2") 'False 155 | ' 156 | Dim arr() As Variant 157 | Dim arr2D(0 To 2, 0 To 3) As Variant 158 | Dim arr3D(1 To 3, 1 To 2, 1 To 5) As Variant 159 | Dim arr4D(1 To 2, 1 To 3, 1 To 4, 1 To 5) As Variant 160 | Dim dimensionsCount As Long 161 | Dim elementsCount As Long 162 | ' 163 | 'Get the number of dimensions for an array 164 | dimensionsCount = GetArrayDimsCount(7) '0 165 | dimensionsCount = GetArrayDimsCount(arr) '0 166 | dimensionsCount = GetArrayDimsCount(Array()) '1 167 | dimensionsCount = GetArrayDimsCount(arr2D) '2 168 | dimensionsCount = GetArrayDimsCount(arr3D) '3 169 | dimensionsCount = GetArrayDimsCount(arr4D) '4 170 | ' 171 | 'Get the number of elements for an array 172 | elementsCount = GetArrayElemCount(5) '0 173 | elementsCount = GetArrayElemCount(arr) '0 174 | elementsCount = GetArrayElemCount(Array(1, 5, 6)) '3 175 | elementsCount = GetArrayElemCount(arr2D) '12 176 | elementsCount = GetArrayElemCount(arr3D) '30 177 | elementsCount = GetArrayElemCount(arr4D) '120 178 | ' 179 | 'Check if a variant support For...Each loop 180 | boolExpression = IsIterable(arr) 'False 181 | boolExpression = IsIterable(Array()) 'True 182 | boolExpression = IsIterable(coll) 'True 183 | boolExpression = IsIterable(Nothing) 'False 184 | End Sub 185 | 186 | Public Sub DemoSort() 187 | Dim arr() As Variant 188 | ' 189 | 'Sort 1D Array with default options 190 | arr = Sort1DArray(Array(1, "2", 2, Null, Empty, vbNullString, "test", 5, "4", 1)) 191 | 'Result: 192 | ' [1,1,"2",2,"4",5,"","test",Null,Empty] 193 | ' 194 | 'Sort 1D Array while considering numbers stored as text to be just text 195 | arr = Sort1DArray(Array(1, "2", 2, Null, Empty, vbNullString, "test", 5, "4", 1), True, False) 196 | 'Result: 197 | ' [1,1,2,5,","2","4","","test",Null,Empty] 198 | ' 199 | 'Sort 1D Array with default options 200 | arr = Sort1DArray(Array("bB", "aa", "Ab", "Aa", "ba", "cc", "CC")) 201 | 'Result: 202 | ' ["aa","Aa","Ab","ba","bB","cc","CC"] 203 | ' 204 | 'Sort 1D Array with case sensitive texts 205 | arr = Sort1DArray(Array("bB", "aa", "Ab", "Aa", "ba", "cc", "CC"), , , True) 206 | 'Result: 207 | ' ["Aa","Ab","CC","aa","bB","ba","cc"] 208 | ' 209 | arr = LibArrayTools.OneDArrayTo2DArray(Array(4, 2, 3, 1, 4, 1, 2, 2, 4, 3, 1, 2, 1, 1, 2, 1, 1, 3), 2) 210 | '[4,2] 211 | '[3,1] 212 | '[4,1] 213 | '[2,2] 214 | '[4,3] 215 | '[1,2] 216 | '[1,1] 217 | '[2,1] 218 | '[1,3] 219 | ' 220 | 'Sort a 2D Array twice by 2 different columns 221 | arr = Sort2DArray(Sort2DArray(arr, 1), 0) 222 | 'Result: 223 | ' [1,1] 224 | ' [1,2] 225 | ' [1,3] 226 | ' [2,1] 227 | ' [2,2] 228 | ' [3,1] 229 | ' [4,1] 230 | ' [4,2] 231 | ' [4,3] 232 | ' 233 | Dim coll As Collection 234 | ' 235 | 'Sort a Collection 236 | Set coll = SortCollection(Collection(1, 2, 5, 2, 3, 4, 3, 6)) 237 | 'Result: 238 | ' [1,2,2,3,3,4,5,6] 239 | End Sub 240 | 241 | Public Sub DemoSlicing() 242 | Dim arr() As Variant 243 | Dim coll As Collection 244 | ' 245 | 'Slicing a 1D Array 246 | arr = Slice1DArray(Array(1, 2, 3, 4, 5, 6), 3, 2) 247 | 'Result: 248 | ' [4,5] 249 | arr = Slice1DArray(Array(1, 2, 3, 4, 5, 6), 2, 1) 250 | 'Result: 251 | ' [3] 252 | arr = Slice1DArray(Array(1, 2, 3, 4, 5, 6), 4, 5) 253 | 'Result (note that excess length is ignored): 254 | ' [5,6] 255 | ' 256 | arr = OneDArrayTo2DArray(Array(1, 2, 3, 4, 5, 6, 7, 8), 4) 257 | '[1,2,3,4] 258 | '[5,6,7,8] 259 | ' 260 | 'Slicing a 2D Array 261 | arr = Slice2DArray(arr, 0, 1, 2, 2) 262 | 'Result: 263 | ' [2,3] 264 | ' [6,7] 265 | ' 266 | 'Slicing a Collection 267 | Set coll = SliceCollection(Collection(1, 2, 3, 4, 5, 6), 3, 2) 268 | 'Result: 269 | ' [3,4] 270 | End Sub 271 | -------------------------------------------------------------------------------- /src/LibArrayTools.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "LibArrayTools" 2 | '''============================================================================= 3 | ''' VBA ArrayTools 4 | '''----------------------------------------------- 5 | ''' https://github.com/cristianbuse/VBA-ArrayTools 6 | '''----------------------------------------------- 7 | ''' 8 | ''' Copyright (c) 2012 Ion Cristian Buse 9 | ''' 10 | ''' Permission is hereby granted, free of charge, to any person obtaining a copy 11 | ''' of this software and associated documentation files (the "Software"), to deal 12 | ''' in the Software without restriction, including without limitation the rights 13 | ''' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 14 | ''' copies of the Software, and to permit persons to whom the Software is 15 | ''' furnished to do so, subject to the following conditions: 16 | ''' 17 | ''' The above copyright notice and this permission notice shall be included in all 18 | ''' copies or substantial portions of the Software. 19 | ''' 20 | ''' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 21 | ''' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 22 | ''' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 23 | ''' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 24 | ''' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 25 | ''' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 26 | ''' SOFTWARE. 27 | '''============================================================================= 28 | 29 | Option Explicit 30 | Option Private Module 31 | Option Compare Text 'See Like operator in 'IsValuePassingFilter' method 32 | 33 | '******************************************************************************* 34 | '' Functions in this library module allow Array/Collection manipulation in VBA 35 | '' regardless of: 36 | '' - the host Application (Excel, Word, AutoCAD etc.) 37 | '' - the operating system (Mac, Windows) 38 | '' - application environment (x32, x64) 39 | '' No extra library references are needed (e.g. Microsoft Scripting Runtime) 40 | '' Main features: 41 | '' - conversions: array-array, array-collection, collection-array 42 | '' - sorting 43 | '' - filtering 44 | '' - reversing 45 | '' - slicing 46 | '' - uniquifying 47 | '' - getting Array/Collection information 48 | '******************************************************************************* 49 | 50 | '' Public/Exposed methods (40+): 51 | '' - Collection 52 | '' - CollectionHasKey 53 | '' - CollectionTo1DArray 54 | '' - CollectionTo2DArray 55 | '' - CreateFilter 56 | '' - CreateFiltersArray 57 | '' - Filter1DArray 58 | '' - Filter2DArray 59 | '' - FilterCollection (in-place) 60 | '' - FindTextsRow 61 | '' - GetArrayDimsCount 62 | '' - GetArrayElemCount 63 | '' - GetConditionOperator 64 | '' - GetConditionOperatorText 65 | '' - GetUniqueIntegers 66 | '' - GetUniqueRows 67 | '' - GetUniqueValues 68 | '' - InsertRowsAtIndex 69 | '' - InsertRowsAtValChange 70 | '' - IntegerRange1D 71 | '' - Is2DArrayRowEmpty 72 | '' - IsIterable 73 | '' - IsValuePassingFilter 74 | '' - Merge1DArrays 75 | '' - Merge2DArrays 76 | '' - NDArrayTo1DArray (row-wise or column-wise) 77 | '' - NDArrayToCollections 78 | '' - OneDArrayTo2DArray 79 | '' - OneDArrayToCollection 80 | '' - RemoveEmptyRows (in-place) 81 | '' - ReplaceEmptyInArray (in-place) 82 | '' - ReplaceNullInArray (in-place) 83 | '' - Reverse1DArray (in-place) 84 | '' - Reverse2DArray (in-place) 85 | '' - ReverseCollection (in-place) 86 | '' - Sequence1D 87 | '' - Sequence2D 88 | '' - ShallowCopyCollection 89 | '' - Slice1DArray 90 | '' - Slice2DArray 91 | '' - SliceCollection 92 | '' - Sort1DArray (in-place) 93 | '' - Sort2DArray (in-place) 94 | '' - SortCollection (in-place) 95 | '' - SwapValues (in-place) 96 | '' - TextArrayToIndex 97 | '' - TransposeArray 98 | '' - ValuesToCollection 99 | 100 | '******************************************************************************* 101 | ''Note that the 'Set' keyword is not needed when assigning a Variant variable of 102 | '' type VbVarType.vbDataObject to another Variant (e.g. v1 = v2) but it is 103 | '' needed when Variants of type vbDataObject are returned from methods or 104 | '' object properties (e.g. Set v1 = collection.Item(1)) 105 | '******************************************************************************* 106 | 107 | 'Used for raising errors 108 | Private Const MODULE_NAME As String = "LibArrayTools" 109 | 110 | 'Ways of traversing an array 111 | Public Enum ARRAY_TRAVERSE_TYPE 'In VBA, arrays are stored in columnMajorOrder 112 | columnWise = 0 113 | rowWise = 1 114 | End Enum 115 | 116 | 'Custom Structure to describe an array Dimension 117 | Private Type ARRAY_DIMENSION 118 | index As Long 'the ordinal of the dimension 1-1st, 2-2nd ... 119 | size As Long 'the number of elements in the dimension 120 | depth As Long 'the product of lower dimension (higher index) sizes 121 | End Type 122 | 123 | 'Custom Structure to describe the dimensions and elements of an array 124 | Private Type ARRAY_DESCRIPTOR 125 | dimsCount As Long 126 | dimensions() As ARRAY_DIMENSION 127 | elemCount As Long 128 | elements1D As Variant 129 | traverseType As ARRAY_TRAVERSE_TYPE 130 | rowMajorIndexes() As Long 131 | End Type 132 | 133 | 'Vector type (see QuickSortVector method) 134 | Private Enum VECTOR_TYPE 135 | vecArray = 1 136 | vecCollection = 2 137 | End Enum 138 | 139 | 'Rank for categorizing different data types (used for comparing values/sorting) 140 | Private Enum DATA_TYPE_RANK 141 | rankEmpty = 1 142 | rankUDT = 2 143 | rankObject = 3 144 | rankArray = 4 145 | rankNull = 5 146 | rankError = 6 147 | rankBoolean = 7 148 | rankText = 8 149 | rankNumber = 9 150 | End Enum 151 | 152 | 'The result of a comparison between 2 values (for the purpose of sorting) 153 | Private Type COMPARE_RESULT 154 | mustSwap As Boolean 155 | areEqual As Boolean 156 | End Type 157 | 158 | 'Struct used for passing compare-related options between relevant methods 159 | Private Type COMPARE_OPTIONS 160 | compAscending As Boolean 161 | useTextNumberAsNumber As Boolean 162 | compareMethod As VbCompareMethod 163 | End Type 164 | 165 | 'Struct used for storing a quick sort pivot's value and corresponding index 166 | Private Type SORT_PIVOT 167 | index As Long 168 | value_ As Variant 169 | End Type 170 | 171 | 'Available Operators for testing conditions (see FILTER_PAIR struct) 172 | Public Enum CONDITION_OPERATOR 173 | opNone = 0 174 | opEqual = 1 175 | [_opMin] = 1 176 | opSmaller = 2 177 | opBigger = 3 178 | opSmallerOrEqual = 4 179 | opBiggerOrEqual = 5 180 | opNotEqual = 6 181 | opin = 7 182 | opNotIn = 8 183 | opLike = 9 184 | opNotLike = 10 185 | [_opMax] = 10 186 | End Enum 187 | 188 | 'Struct used for filtering (see FILTER_PAIR struct) 189 | Private Type COMPARE_VALUE 190 | value_ As Variant 191 | rank_ As DATA_TYPE_RANK 192 | isIterable_ As Boolean 193 | textKeys_ As Collection 'used when 'value_' is iterable (Array/Collection) 194 | End Type 195 | 196 | 'Struct used for filtering (see Filter2DArray method) 197 | '******************************************************************************* 198 | 'If used as a parameter in a class method or as a return value of a class method 199 | ' then make sure to declare the class method as Friend. Otherwise the only 200 | ' other way to make the code compile is to remove the Option Private Module 201 | ' from the top of this module. Note that removing Option Private Module would 202 | ' expose the methods of this module (for example in Excel they can be seen as 203 | ' custom functions in the Excel interface - which is undesirable as they are 204 | ' not intended as UDFs) 205 | '******************************************************************************* 206 | Public Type FILTER_PAIR 207 | cOperator As CONDITION_OPERATOR 208 | compValue As COMPARE_VALUE 209 | End Type 210 | 211 | 'Struct used in ValuesToCollection 212 | Public Enum NESTING_TYPE 213 | nestNone = 0 214 | [_nMin] = nestNone 215 | nestMultiItemsOnly = 1 216 | nestAll = 2 217 | [_nMax] = 2 218 | End Enum 219 | 220 | 'vbLongLong is a VbVarType available in x64 systems only 221 | 'Create the value for x32 for convenience in writing Select Case logic 222 | #If Mac Then 223 | Const vbLongLong As Long = 20 'Apparently missing for x64 on Mac 224 | #Else 225 | #If Win64 = 0 Then 226 | Const vbLongLong As Long = 20 227 | #End If 228 | #End If 229 | 230 | 'Structs needed for ZeroLengthArray method 231 | Private Type SAFEARRAYBOUND 232 | cElements As Long 233 | lLbound As Long 234 | End Type 235 | Private Type TagVariant 236 | vt As Integer 237 | wReserved1 As Integer 238 | wReserved2 As Integer 239 | wReserved3 As Integer 240 | #If VBA7 Then 241 | ptr As LongPtr 242 | #Else 243 | ptr As Long 244 | #End If 245 | End Type 246 | 247 | 'Win APIs needed for ZeroLengthArray method 248 | #If Mac Then 249 | #Else 250 | #If VBA7 Then 251 | Private Declare PtrSafe Function SafeArrayCreate Lib "OleAut32.dll" (ByVal vt As Integer, ByVal cDims As Long, ByRef rgsabound As SAFEARRAYBOUND) As LongPtr 252 | Private Declare PtrSafe Function VariantCopy Lib "OleAut32.dll" (pvargDest As Any, pvargSrc As Any) As Long 253 | Private Declare PtrSafe Function SafeArrayDestroy Lib "OleAut32.dll" (ByVal psa As LongPtr) As Long 254 | #Else 255 | Private Declare Function SafeArrayCreate Lib "OleAut32.dll" (ByVal vt As Integer, ByVal cDims As Long, ByRef rgsabound As SAFEARRAYBOUND) As Long 256 | Private Declare Function VariantCopy Lib "OleAut32.dll" (pvargDest As Variant, pvargSrc As Any) As Long 257 | Private Declare Function SafeArrayDestroy Lib "OleAut32.dll" (ByVal psa As Long) As Long 258 | #End If 259 | #End If 260 | 261 | '******************************************************************************* 262 | 'Returns a new collection containing the specified values 263 | 'Similar with [_HiddenModule].Array but returns a collection 264 | 'Parameters: 265 | ' - values: a ParamArray Variant containing values to be added to collection 266 | 'Does not raise errors 267 | 'Examples: 268 | ' - Collection() returns [] (a New empty collection) 269 | ' - Collection(1,2,3) returns [1,2,3] (a collection with 3 integers) 270 | ' - Collection(1,2,Collection(3,4)) returns [1,2,[3,4]] 271 | '******************************************************************************* 272 | Public Function Collection(ParamArray values() As Variant) As Collection 273 | Dim v As Variant 274 | Dim coll As Collection 275 | ' 276 | Set coll = New Collection 277 | For Each v In values 278 | coll.Add v 279 | Next v 280 | ' 281 | Set Collection = coll 282 | End Function 283 | 284 | '******************************************************************************* 285 | 'Returns a boolean indicating if a Collection has a specific key 286 | 'Parameters: 287 | ' - coll: a collection to check for key 288 | ' - keyValue: the key being searched for 289 | 'Does not raise errors 290 | '******************************************************************************* 291 | Public Function CollectionHasKey(ByVal coll As Collection _ 292 | , ByRef keyValue As String) As Boolean 293 | On Error Resume Next 294 | coll.Item keyValue 295 | CollectionHasKey = (Err.Number = 0) 296 | On Error GoTo 0 297 | End Function 298 | 299 | '******************************************************************************* 300 | 'Returns a 1D array based on values contained in the specified collection 301 | 'Parameters: 302 | ' - coll: collection that contains the values to be used 303 | ' - [outLowBound]: the start index of the result array. Default is 0 304 | 'Raises error: 305 | ' - 91: if Collection Object is not set 306 | '******************************************************************************* 307 | Public Function CollectionTo1DArray(ByVal coll As Collection _ 308 | , Optional ByVal outLowBound As Long = 0) As Variant() 309 | Const fullMethodName As String = MODULE_NAME & ".CollectionTo1DArray" 310 | ' 311 | 'Check Input 312 | If coll Is Nothing Then 313 | Err.Raise 91, fullMethodName, "Collection not set" 314 | ElseIf coll.Count = 0 Then 315 | CollectionTo1DArray = ZeroLengthArray() 316 | Exit Function 317 | End If 318 | ' 319 | Dim res() As Variant: ReDim res(outLowBound To outLowBound + coll.Count - 1) 320 | Dim i As Long: i = outLowBound 321 | Dim v As Variant 322 | ' 323 | 'Populate array 324 | For Each v In coll 325 | If IsObject(v) Then Set res(i) = v Else res(i) = v 326 | i = i + 1 327 | Next v 328 | ' 329 | CollectionTo1DArray = res 330 | End Function 331 | 332 | '******************************************************************************* 333 | 'Returns a 2D array based on values contained in the specified collection 334 | 'Parameters: 335 | ' - coll: collection that contains the values to be used 336 | ' - columnsCount: the number of columns that the result 2D array will have 337 | ' - [outLowRow]: the start index of the result's 1st dimension. Default is 0 338 | ' - [outLowCol]: the start index of the result's 2nd dimension. Default is 0 339 | 'Raises error: 340 | ' - 91: if Collection Object is not set 341 | ' - 5: if the number of columns is less than 1 342 | 'Notes: 343 | ' - if the total Number of values is not divisible by columnsCount then the 344 | ' extra values (last row) of the array are by default the value Empty 345 | 'Examples: 346 | ' - coll = [1,2,3,4] and columnsCount = 1 >> returns [1] 347 | ' [2] 348 | ' [3] 349 | ' [4] (4 rows 1 column) 350 | ' - coll = [1,2,3,4] and columnsCount = 2 >> returns [1,2] 351 | ' [3,4] (2 rows 2 columns) 352 | ' - coll = [1,2,3] and columnsCount = 2 >> returns [1,2] 353 | ' [3,Empty] 354 | '******************************************************************************* 355 | Public Function CollectionTo2DArray(ByVal coll As Collection _ 356 | , ByVal columnsCount As Long _ 357 | , Optional ByVal outLowRow As Long = 0 _ 358 | , Optional ByVal outLowCol As Long = 0) As Variant() 359 | Const fullMethodName As String = MODULE_NAME & ".CollectionTo2DArray" 360 | ' 361 | 'Check Input 362 | If coll Is Nothing Then 363 | Err.Raise 91, fullMethodName, "Collection not set" 364 | ElseIf columnsCount < 1 Then 365 | Err.Raise 5, fullMethodName, "Invalid Columns Count" 366 | ElseIf coll.Count = 0 Then 367 | CollectionTo2DArray = ZeroLengthArray() 368 | Exit Function 369 | End If 370 | ' 371 | Dim rowsCount As Long: rowsCount = -Int(-coll.Count / columnsCount) 372 | Dim arr() As Variant: ReDim arr(outLowRow To outLowRow + rowsCount - 1 _ 373 | , outLowCol To outLowCol + columnsCount - 1) 374 | Dim i As Long: i = 0 375 | Dim r As Long 376 | Dim c As Long 377 | Dim v As Variant 378 | ' 379 | 'Populate array 380 | For Each v In coll 381 | r = outLowRow + i \ columnsCount 382 | c = outLowCol + i Mod columnsCount 383 | If IsObject(v) Then Set arr(r, c) = v Else arr(r, c) = v 384 | i = i + 1 385 | Next v 386 | ' 387 | CollectionTo2DArray = arr 388 | End Function 389 | 390 | '******************************************************************************* 391 | 'Creates a FILTER_PAIR struct from values 392 | 'Parameters: 393 | ' - cOperator - see CONDITION_OPERATOR enum and GetConditionOperator method 394 | ' - compareValue: any value 395 | 'Notes: 396 | ' - see 'GetConditionOperator' for the operator conversion 397 | '******************************************************************************* 398 | Public Function CreateFilter(ByVal cOperator As CONDITION_OPERATOR _ 399 | , ByVal compareValue As Variant) As FILTER_PAIR 400 | If cOperator >= [_opMin] And cOperator <= [_opMax] Then 401 | CreateFilter.cOperator = cOperator 402 | End If 403 | With CreateFilter.compValue 404 | .rank_ = GetDataTypeRank(compareValue) 405 | If .rank_ = rankArray Or .rank_ = rankObject Then 406 | .isIterable_ = IsIterable(compareValue) 407 | If .isIterable_ Then Set .textKeys_ = CreateTextKeys(compareValue) 408 | End If 409 | If .rank_ = rankObject Then 410 | Set .value_ = compareValue 411 | Else 412 | .value_ = compareValue 413 | End If 414 | End With 415 | End Function 416 | 417 | '******************************************************************************* 418 | 'Creates a collection with text keys corresponding to the received values. 419 | 'Utility for 'CreateFilter' method 420 | '******************************************************************************* 421 | Private Function CreateTextKeys(ByRef values As Variant) As Collection 422 | Dim collResult As Collection: Set collResult = New Collection 423 | Dim keyValue As String 424 | Dim v As Variant 425 | ' 426 | On Error Resume Next 'Ignore duplicates 427 | For Each v In values 428 | keyValue = GetUniqueTextKey(v) 429 | If LenB(keyValue) > 0 Then collResult.Add keyValue, keyValue 430 | Next v 431 | On Error GoTo 0 432 | Set CreateTextKeys = collResult 433 | End Function 434 | 435 | '******************************************************************************* 436 | 'Creates an array of FILTER_PAIR structs from a variant of valuePairs 437 | 'Parameters: 438 | ' - valuePairs: a ParamArray Variant containing any number of filter pairs: 439 | ' * operator: 440 | ' + textOperator (see 'GetConditionOperator' method): 441 | ' ~ comparison operators: =, <, >, <=, >=, <> 442 | ' ~ inclusion operators: IN , NOT IN 443 | ' ~ pattern matching operators: LIKE, NOT LIKE 444 | ' + enumOperator (see CONDITION_OPERATOR enum) 445 | ' * compareValue: any value 446 | 'Raises error: 447 | ' - 5 if: 448 | ' * no value is provided 449 | ' * number of elements in 'valuePairs' is not divisible by 2 450 | ' * operator is invalid (wrong data type or not supported) 451 | 'Notes: 452 | ' - this method can be used to quickly create an array of FILTER_PAIRs to be 453 | ' used with the 'Filter...' methods 454 | '******************************************************************************* 455 | Public Function CreateFiltersArray(ParamArray valuePairs() As Variant) As FILTER_PAIR() 456 | Const fullMethodName As String = MODULE_NAME & ".CreateFiltersArray" 457 | ' 458 | Dim collFilterPairs As Collection 459 | Dim v As Variant: v = valuePairs 460 | ' 461 | 'Check Input 462 | Set collFilterPairs = ValuesToCollection(v, nestMultiItemsOnly, rowWise) 463 | If collFilterPairs.Count = 0 Then 464 | Err.Raise 5, fullMethodName, "Expected at least one filter" 465 | ElseIf collFilterPairs.Count Mod 2 <> 0 Then 466 | Err.Raise 5, fullMethodName, "Expected filter pairs of operator & value" 467 | End If 468 | ' 469 | Dim arr() As FILTER_PAIR: ReDim arr(0 To collFilterPairs.Count / 2 - 1) 470 | Dim filter As FILTER_PAIR 471 | Dim cOperator As CONDITION_OPERATOR 472 | Dim isOperator As Boolean: isOperator = True 473 | Dim i As Long: i = 0 474 | ' 475 | For Each v In collFilterPairs 476 | If isOperator Then 477 | Select Case VarType(v) 478 | Case vbLong: cOperator = v 479 | Case vbString: cOperator = GetConditionOperator(v) 480 | Case Else: cOperator = opNone 481 | End Select 482 | Else 483 | filter = CreateFilter(cOperator, v) 484 | If filter.cOperator = opNone Then 485 | Err.Raise 5, fullMethodName, "Invalid operator" 486 | End If 487 | arr(i) = filter 488 | i = i + 1 489 | End If 490 | isOperator = Not isOperator 491 | Next v 492 | ' 493 | CreateFiltersArray = arr 494 | End Function 495 | 496 | '******************************************************************************* 497 | 'Returnes the number of dimensions for an array of FILTER_PAIR UDTs 498 | 'Note that the 'GetArrayDimsCount' method cannot be used because UDTs canot be 499 | ' assigned to a Variant 500 | 'Utility for 'Filter...' methods 501 | '******************************************************************************* 502 | Private Function GetFiltersDimsCount(ByRef arr() As FILTER_PAIR) As Long 503 | Const MAX_DIMENSION As Long = 60 504 | Dim dimension As Long 505 | Dim tempBound As Long 506 | ' 507 | On Error GoTo FinalDimension 508 | For dimension = 1 To MAX_DIMENSION 509 | tempBound = LBound(arr, dimension) 510 | Next dimension 511 | FinalDimension: 512 | GetFiltersDimsCount = dimension - 1 513 | End Function 514 | 515 | '******************************************************************************* 516 | 'Filters a 1D Array 517 | 'Parameters: 518 | ' - arr: a 1D array to be filtered 519 | ' - filters: an array of FILTER_PAIR structs (operator/compareValue pairs) 520 | ' - [outLowBound]: the start index of the result array. Default is 0 521 | 'Raises Error: 522 | ' - 5 if: 523 | ' * 'arr' is not 1D 524 | ' * values are incompatible (see 'IsValuePassingFilter' method) 525 | 'Notes: 526 | ' - use the 'CreateFiltersArray' method to quickly create filters 527 | 'Examples: 528 | ' - arr = [1,2,3,4] and filters = [">",2,"<=",4] >> returns [3,4] 529 | ' - arr = [1,3,6,9] and filters = ["IN",[1,2,3,4]] >> returns [1,3] 530 | ' - arr = ["test","hes","et"] and filters = ["LIKE","*es?"] > returns ["test"] 531 | '******************************************************************************* 532 | Public Function Filter1DArray(ByRef arr As Variant _ 533 | , ByRef filters() As FILTER_PAIR _ 534 | , Optional ByVal outLowBound As Long = 0) As Variant() 535 | Const fullMethodName As String = MODULE_NAME & ".Filter1DArray" 536 | ' 537 | 'Check Input 538 | If GetArrayDimsCount(arr) <> 1 Then 539 | Err.Raise 5, fullMethodName, "Expected 1D Array for filtering" 540 | ElseIf GetFiltersDimsCount(filters) <> 1 Then 541 | Err.Raise 5, fullMethodName, "Expected 1D Array of filters" 542 | End If 543 | ' 544 | Dim i As Long 545 | Dim collIndexes As New Collection 546 | ' 547 | 'Create collecton of indexes with keys for easy removal 548 | For i = LBound(arr, 1) To UBound(arr, 1) 549 | collIndexes.Add i, CStr(i) 550 | Next 551 | ' 552 | Dim filter As FILTER_PAIR 553 | Dim v As Variant 554 | ' 555 | 'Remove indexes for values that do NOT pass filters 556 | On Error GoTo ErrorHandler 557 | For i = LBound(filters, 1) To UBound(filters, 1) 558 | filter = filters(i) 559 | For Each v In collIndexes 560 | If Not IsValuePassingFilter(arr(v), filter) Then 561 | collIndexes.Remove CStr(v) 562 | End If 563 | Next v 564 | If collIndexes.Count = 0 Then 565 | Filter1DArray = ZeroLengthArray() 566 | Exit Function 567 | End If 568 | Next i 569 | ' 570 | Dim res() As Variant 571 | Dim j As Long 572 | ' 573 | 'Copy values to the result array 574 | ReDim res(outLowBound To outLowBound + collIndexes.Count - 1) 575 | i = outLowBound 576 | For Each v In collIndexes 577 | j = CLng(v) 578 | If IsObject(arr(j)) Then Set res(i) = arr(j) Else res(i) = arr(j) 579 | i = i + 1 580 | Next v 581 | ' 582 | Filter1DArray = res 583 | Exit Function 584 | ErrorHandler: 585 | Err.Raise Err.Number _ 586 | , Err.Source & vbNewLine & fullMethodName _ 587 | , Err.Description & vbNewLine & "Invalid filters or values" 588 | End Function 589 | 590 | '******************************************************************************* 591 | 'Filters a 2D Array by a specified column 592 | 'Parameters: 593 | ' - arr: a 2D array to be filtered 594 | ' - byColumn: the index of the column used for filtering 595 | ' - filters: an array of FILTER_PAIR (operator/compareValue pairs) 596 | ' - [outLowRow]: start index of the result array's 1st dimension. Default is 0 597 | 'Raises Error: 598 | ' - 5 if: 599 | ' * 'arr' is not 2D 600 | ' * 'filters' is not 1D 601 | ' * 'byColumn' is out of bounds 602 | ' * values are incompatible (see 'IsValuePassingFilter' method) 603 | 'Notes: 604 | ' - column lower bound is preserved (same as the original array) 605 | '******************************************************************************* 606 | Public Function Filter2DArray(ByRef arr As Variant _ 607 | , ByVal byColumn As Long _ 608 | , ByRef filters() As FILTER_PAIR _ 609 | , Optional ByVal outLowRow As Long = 0) As Variant() 610 | Const fullMethodName As String = MODULE_NAME & ".Filter2DArray" 611 | ' 612 | 'Check Input 613 | If GetArrayDimsCount(arr) <> 2 Then 614 | Err.Raise 5, fullMethodName, "Expected 2D Array for filtering" 615 | ElseIf byColumn < LBound(arr, 2) Or byColumn > UBound(arr, 2) Then 616 | Err.Raise 5, fullMethodName, "Invalid column index" 617 | ElseIf GetFiltersDimsCount(filters) <> 1 Then 618 | Err.Raise 5, fullMethodName, "Expected 1D Array of filters" 619 | End If 620 | ' 621 | Dim i As Long 622 | Dim collRows As New Collection 623 | ' 624 | 'Create collecton of row indexes with keys for easy removal 625 | For i = LBound(arr, 1) To UBound(arr, 1) 626 | collRows.Add i, CStr(i) 627 | Next 628 | ' 629 | Dim filter As FILTER_PAIR 630 | Dim v As Variant 631 | ' 632 | 'Remove row indexes for values that do NOT pass filters 633 | On Error GoTo ErrorHandler 634 | For i = LBound(filters, 1) To UBound(filters, 1) 635 | filter = filters(i) 636 | For Each v In collRows 637 | If Not IsValuePassingFilter(arr(v, byColumn), filter) Then 638 | collRows.Remove CStr(v) 639 | End If 640 | Next v 641 | If collRows.Count = 0 Then 642 | Filter2DArray = ZeroLengthArray() 643 | Exit Function 644 | End If 645 | Next i 646 | ' 647 | Dim lowCol As Long: lowCol = LBound(arr, 2) 648 | Dim uppCol As Long: uppCol = UBound(arr, 2) 649 | Dim res() As Variant: ReDim res(outLowRow To outLowRow + collRows.Count - 1 _ 650 | , lowCol To uppCol) 651 | Dim needSet As Boolean 652 | Dim r As Long 653 | Dim j As Long 654 | ' 655 | 'Copy rows to the result array 656 | i = outLowRow 657 | For Each v In collRows 658 | r = CLng(v) 659 | For j = lowCol To uppCol 660 | needSet = IsObject(arr(r, j)) 661 | If needSet Then Set res(i, j) = arr(r, j) Else res(i, j) = arr(r, j) 662 | Next j 663 | i = i + 1 664 | Next v 665 | ' 666 | Filter2DArray = res 667 | Exit Function 668 | ErrorHandler: 669 | Err.Raise Err.Number _ 670 | , Err.Source & vbNewLine & fullMethodName _ 671 | , Err.Description & vbNewLine & "Invalid filters or values" 672 | End Function 673 | 674 | '******************************************************************************* 675 | 'Filters a Collection in-place 676 | 'Parameters: 677 | ' - coll: a collection to be filtered 678 | ' - filters: an array of FILTER_PAIR (operator/compareValue pairs) 679 | 'Notes: 680 | ' - the collection is modified in place so it is optional to use the return 681 | ' value of the function 682 | 'Raises Error: 683 | ' - 91: if Collection Object is not set 684 | ' - 5 if: 685 | ' * 'filters' is not 1D 686 | ' * values are incompatible (see 'IsValuePassingFilter' method) 687 | '******************************************************************************* 688 | Public Function FilterCollection(ByVal coll As Collection _ 689 | , ByRef filters() As FILTER_PAIR) As Collection 690 | Const fullMethodName As String = MODULE_NAME & ".FilterCollection" 691 | ' 692 | 'Check Input 693 | If coll Is Nothing Then 694 | Err.Raise 91, fullMethodName, "Collection not set" 695 | ElseIf GetFiltersDimsCount(filters) <> 1 Then 696 | Err.Raise 5, fullMethodName, "Expected 1D Array of filters" 697 | ElseIf coll.Count = 0 Then 698 | Set FilterCollection = coll 699 | Exit Function 700 | End If 701 | ' 702 | Dim filter As FILTER_PAIR 703 | Dim v As Variant 704 | Dim i As Long 705 | Dim j As Long 706 | ' 707 | 'Remove values that do NOT pass filters 708 | On Error GoTo ErrorHandler 709 | For i = LBound(filters, 1) To UBound(filters, 1) 710 | filter = filters(i) 711 | j = 1 712 | For Each v In coll 713 | If IsValuePassingFilter(v, filter) Then 714 | j = j + 1 715 | Else 716 | coll.Remove j 717 | End If 718 | Next v 719 | Next i 720 | ' 721 | Set FilterCollection = coll 'Useful for method chaining 722 | Exit Function 723 | ErrorHandler: 724 | Err.Raise Err.Number _ 725 | , Err.Source & vbNewLine & fullMethodName _ 726 | , Err.Description & vbNewLine & "Invalid filters or values" 727 | End Function 728 | 729 | '******************************************************************************* 730 | 'Find an array of texts in a source array and return the row index 731 | 'Example usage: finding required table headers 732 | 'Parameters: 733 | ' - arr: a 2D array to search into 734 | ' - iterableTexts: an array, collection or other object that can be iterated 735 | ' using a For Each... Next loop 736 | ' - [maxRowsToSearch]: limit the number of rows to search from the top. 737 | ' Default is 0 (all rows) 738 | ' - [maxCharsToMatch]: limit the number of characters to match. 739 | ' Default is 0 (all characters) 740 | ' - [caseSensitive]: * True - compare texts as case-sensitive 741 | ' * False - ignore case when comparing texts (default) 742 | 'Notes: 743 | ' - consider limiting 'maxCharsToMatch' to 255 when searching for Excel list 744 | ' object headers or formulas as these are limited to 255 characters 745 | ' - if not all texts are found then this method returns an invalid row index 746 | ' less than the lower row bound i.e. LBound(arr, 1) - 1 747 | 'Raises Error: 748 | ' - 5 if: 749 | ' * 'arr' is not 2D 750 | ' * any value in 'iterableTexts' is not a String 751 | '******************************************************************************* 752 | Public Function FindTextsRow(ByRef arr() As Variant _ 753 | , ByRef iterableTexts As Variant _ 754 | , Optional ByVal maxRowsToSearch As Long = 0 _ 755 | , Optional ByVal maxCharsToMatch As Long = 0 _ 756 | , Optional ByVal caseSensitive As Boolean = False) As Long 757 | Const fullMethodName As String = MODULE_NAME & ".FindTextsRow" 758 | ' 759 | If GetArrayDimsCount(arr) <> 2 Then 760 | Err.Raise 5, fullMethodName, "Expected 2D array source data" 761 | ElseIf maxRowsToSearch <= 0 Then 'Search all rows 762 | maxRowsToSearch = UBound(arr, 1) - LBound(arr, 1) + 1 763 | End If 764 | ' 765 | Dim h As Variant 766 | Dim s As String 767 | Dim collTexts As New Collection 768 | ' 769 | On Error Resume Next 770 | For Each h In iterableTexts 771 | s = CStr(h) 772 | If Err.Number <> 0 Then 773 | On Error GoTo 0 774 | Err.Raise 5, fullMethodName, "Expected text values to search for" 775 | End If 776 | If maxCharsToMatch > 0 Then 777 | If Len(s) > maxCharsToMatch Then s = Left$(s, maxCharsToMatch) 778 | End If 779 | collTexts.Add s, s 780 | If Err.Number <> 0 Then Err.Clear 'Ignore duplicates 781 | Next h 782 | On Error GoTo 0 783 | If collTexts.Count = 0 Then GoTo Fail 784 | ' 785 | Dim i As Long 786 | Dim j As Long 787 | Dim rowsSearched As Long 788 | Dim isRowFound As Boolean 789 | Dim isColFound As Boolean 790 | Dim lowCol As Long: lowCol = LBound(arr, 2) 791 | Dim uppCol As Long: uppCol = UBound(arr, 2) 792 | Dim cMethod As VbCompareMethod 793 | Dim lenH As Long 794 | Dim lenS As Long 795 | ' 796 | If caseSensitive Then cMethod = vbBinaryCompare Else cMethod = vbTextCompare 797 | For i = LBound(arr, 1) To UBound(arr, 1) 798 | isRowFound = True 799 | ' 800 | For Each h In collTexts 801 | lenH = Len(h) 802 | isColFound = False 803 | ' 804 | For j = lowCol To uppCol 805 | If VarType(arr(i, j)) = vbString Then 806 | s = arr(i, j) 807 | lenS = Len(s) 808 | If maxCharsToMatch > 0 Then 809 | If lenH = maxCharsToMatch And lenS > maxCharsToMatch Then 810 | s = Left$(s, maxCharsToMatch) 811 | lenS = maxCharsToMatch 812 | End If 813 | End If 814 | If lenH = lenS Then 815 | isColFound = (StrComp(s, h, cMethod) = 0) 816 | If isColFound Then Exit For 817 | End If 818 | End If 819 | Next j 820 | If Not isColFound Then 821 | isRowFound = False 822 | Exit For 823 | End If 824 | Next h 825 | ' 826 | If isRowFound Then 827 | FindTextsRow = i 828 | Exit Function 829 | End If 830 | ' 831 | rowsSearched = rowsSearched + 1 832 | If rowsSearched = maxRowsToSearch Then Exit For 833 | Next i 834 | Fail: 835 | FindTextsRow = LBound(arr, 1) - 1 836 | End Function 837 | 838 | '******************************************************************************* 839 | 'Returns the Number of dimensions for an input array 840 | 'Returns 0 if array is uninitialized or input not an array 841 | 'Note that a zero-length array has 1 dimension! Ex. Array() bounds are (0 to -1) 842 | '******************************************************************************* 843 | Public Function GetArrayDimsCount(ByRef arr As Variant) As Long 844 | Const MAX_DIMENSION As Long = 60 'VB limit 845 | Dim dimension As Long 846 | Dim tempBound As Long 847 | ' 848 | On Error GoTo FinalDimension 849 | For dimension = 1 To MAX_DIMENSION 850 | tempBound = LBound(arr, dimension) 851 | Next dimension 852 | FinalDimension: 853 | GetArrayDimsCount = dimension - 1 854 | End Function 855 | 856 | '******************************************************************************* 857 | 'Returns the Number of elements for an input array 858 | 'Returns 0 if array is uninitialized/zero-length or if input is not an array 859 | '******************************************************************************* 860 | Public Function GetArrayElemCount(ByRef arr As Variant) As Long 861 | On Error Resume Next 862 | GetArrayElemCount = GetArrayDescriptor(arr, rowWise, False).elemCount 863 | On Error GoTo 0 864 | End Function 865 | 866 | '******************************************************************************* 867 | 'Converts a string representation of an operator to it's corresponding Enum: 868 | ' * comparison operators: =, <, >, <=, >=, <> 869 | ' * inclusion operators: IN, NOT IN 870 | ' * pattern matching operators: LIKE, NOT LIKE 871 | 'A Static Keyed Collection is used for fast retrieval (instead of Select Case) 872 | 'Does not raise errors 873 | '******************************************************************************* 874 | Public Function GetConditionOperator(ByVal textOperator As String) As CONDITION_OPERATOR 875 | Static collOperators As Collection 876 | ' 877 | If collOperators Is Nothing Then 878 | Set collOperators = New Collection 879 | Dim i As Long 880 | For i = [_opMin] To [_opMax] 881 | collOperators.Add i, GetConditionOperatorText(i) 882 | Next i 883 | End If 884 | ' 885 | On Error Resume Next 886 | GetConditionOperator = collOperators.Item(textOperator) 887 | On Error GoTo 0 888 | End Function 889 | 890 | '******************************************************************************* 891 | 'Converts a CONDITION_OPERATOR enum value to it's string representation 892 | ' * comparison operators: =, <, >, <=, >=, <> 893 | ' * inclusion operators: IN , NOT IN 894 | ' * pattern matching operators: LIKE, NOT LIKE 895 | '******************************************************************************* 896 | Public Function GetConditionOperatorText(ByVal cOperator As CONDITION_OPERATOR) As String 897 | Static arrOperators([_opMin] To [_opMax]) As String 898 | Static isSet As Boolean 899 | ' 900 | If Not isSet Then 901 | arrOperators(opEqual) = "=" 902 | arrOperators(opSmaller) = "<" 903 | arrOperators(opBigger) = ">" 904 | arrOperators(opSmallerOrEqual) = "<=" 905 | arrOperators(opBiggerOrEqual) = ">=" 906 | arrOperators(opNotEqual) = "<>" 907 | arrOperators(opin) = "IN" 908 | arrOperators(opNotIn) = "NOT IN" 909 | arrOperators(opLike) = "LIKE" 910 | arrOperators(opNotLike) = "NOT LIKE" 911 | isSet = True 912 | End If 913 | ' 914 | If cOperator < [_opMin] Or cOperator > [_opMax] Then Exit Function 915 | GetConditionOperatorText = arrOperators(cOperator) 916 | End Function 917 | 918 | '******************************************************************************* 919 | 'Receives an iterable list of integers via a variant and returns a 1D array 920 | ' containing all the unique integer values within specified limits 921 | 'Parameters: 922 | ' - iterableList: an array, collection or other object that can be iterated 923 | ' using a For Each... Next loop 924 | ' - [minValue]: the minimum integer value allowed. Default is -2147483648 925 | ' - [maxValue]: the maximum integer value allowed. Default is +2147483647 926 | 'Raises error: 927 | ' - 5 if: 928 | ' * 'iterableList' does not support For Each... Next loop 929 | ' * if any value from list is not numeric 930 | ' * if any value from list is outside specified limits 931 | 'Notes: 932 | ' - numbers with decimal places are floored using the Int function 933 | '******************************************************************************* 934 | Public Function GetUniqueIntegers(ByRef iterableList As Variant _ 935 | , Optional ByVal minAllowed As Long = &H80000000 _ 936 | , Optional ByVal maxAllowed As Long = &H7FFFFFFF) As Long() 937 | Const fullMethodName As String = MODULE_NAME & ".GetUniqueIntegers" 938 | ' 939 | 'Check Input 940 | If Not IsIterable(iterableList) Then 941 | Err.Raise 5, fullMethodName, "Variant doesn't support For Each... Next" 942 | ElseIf minAllowed > maxAllowed Then 943 | 'Swapping minAllowed with maxAllowed could lead to unwanted results 944 | Err.Raise 5, fullMethodName, "Invalid limits" 945 | End If 946 | ' 947 | Dim v As Variant 948 | Dim collUnique As New Collection 949 | ' 950 | On Error Resume Next 'Ignore duplicates 951 | For Each v In iterableList 952 | 'Check data type and floor numbers with decimal places 953 | Select Case VarType(v) 954 | Case vbByte, vbInteger, vbLong, vbLongLong 955 | 'Integer. Do nothing 956 | Case vbCurrency, vbDecimal, vbDouble, vbSingle, vbDate 957 | v = Int(v) 958 | Case Else 959 | On Error GoTo 0 960 | Err.Raise 5, fullMethodName, "Invalid data type. Expected numeric" 961 | End Select 962 | ' 963 | If v < minAllowed Or v > maxAllowed Then 964 | On Error GoTo 0 965 | Err.Raise 5, fullMethodName, "Value is outside limits" 966 | End If 967 | collUnique.Add v, CStr(v) 968 | Next v 969 | On Error GoTo 0 970 | ' 971 | If collUnique.Count = 0 Then Exit Function 972 | ' 973 | 'Copy unique integers to a result array 974 | Dim res() As Long: ReDim res(0 To collUnique.Count - 1) 975 | Dim i As Long: i = 0 976 | ' 977 | For Each v In collUnique 978 | res(i) = v 979 | i = i + 1 980 | Next v 981 | ' 982 | GetUniqueIntegers = res 983 | End Function 984 | 985 | '******************************************************************************* 986 | 'Receives a 2D Array and returns unique rows based on chosen columns 987 | 'Parameters: 988 | ' - arr: a 2D array 989 | ' - columns_: an array of one or more column indexes to be used 990 | ' - [outLowRow]: start index of the result array's 1st dimension. Default is 0 991 | 'Raises error: 992 | ' - 5: 993 | ' * 'arr' is not a 2D array 994 | ' * column indexes are out of bounds 995 | 'Notes: 996 | ' - column lower bound is preserved (same as the original array) 997 | '******************************************************************************* 998 | Public Function GetUniqueRows(ByRef arr As Variant _ 999 | , ByRef columns_() As Long _ 1000 | , Optional ByVal outLowRow As Long = 0) As Variant() 1001 | Const fullMethodName As String = MODULE_NAME & ".GetUniqueRows" 1002 | ' 1003 | 'Check Input Array 1004 | If GetArrayDimsCount(arr) <> 2 Then 1005 | Err.Raise 5, fullMethodName, "Expected 2D Array of values" 1006 | ElseIf GetArrayDimsCount(columns_) <> 1 Then 1007 | Err.Raise 5, fullMethodName, "Expected 1D Array of column indexes" 1008 | End If 1009 | ' 1010 | Dim lowerCol As Long: lowerCol = LBound(arr, 2) 1011 | Dim upperCol As Long: upperCol = UBound(arr, 2) 1012 | Dim v As Variant 1013 | ' 1014 | 'Check column indexes 1015 | For Each v In columns_ 1016 | If v < lowerCol Or v > upperCol Then 1017 | Err.Raise 5, fullMethodName, "Invalid column index" 1018 | End If 1019 | Next v 1020 | ' 1021 | Dim collRows As New Collection 1022 | Dim rowKey As String 1023 | Dim i As Long 1024 | ' 1025 | 'Create a collection of indexes corresponding to the unique rows 1026 | On Error Resume Next 'Ignore duplicate rows 1027 | For i = LBound(arr, 1) To UBound(arr, 1) 1028 | rowKey = GetRowKey(arr, i, columns_) 1029 | If LenB(rowKey) > 0 Then collRows.Add i, rowKey 1030 | Next i 1031 | On Error GoTo 0 1032 | ' 1033 | Dim res() As Variant: ReDim res(outLowRow To outLowRow + collRows.Count - 1 _ 1034 | , lowerCol To upperCol) 1035 | Dim j As Long 1036 | Dim r As Long 1037 | Dim needsSet As Boolean 1038 | ' 1039 | 'Copy rows to the result array 1040 | i = outLowRow 1041 | For Each v In collRows 1042 | r = CLng(v) 1043 | For j = lowerCol To upperCol 1044 | needsSet = IsObject(arr(r, j)) 1045 | If needsSet Then Set res(i, j) = arr(r, j) Else res(i, j) = arr(r, j) 1046 | Next j 1047 | i = i + 1 1048 | Next v 1049 | GetUniqueRows = res 1050 | End Function 1051 | 1052 | '******************************************************************************* 1053 | 'Returns a string key for an array row and indicated columns 1054 | 'Utility for 'GetUniqueRows' method 1055 | '******************************************************************************* 1056 | Private Function GetRowKey(ByRef arr As Variant _ 1057 | , ByRef rowIndex As Long _ 1058 | , ByRef columns_() As Long) As String 1059 | Dim colIndex As Variant 1060 | Dim rowKey As String 1061 | Dim keyValue As String 1062 | ' 1063 | For Each colIndex In columns_ 1064 | keyValue = GetUniqueTextKey(arr(rowIndex, colIndex)) 1065 | If LenB(keyValue) = 0 Then Exit Function 'Ignore rows with Arrays/UDTs 1066 | rowKey = rowKey & keyValue 'No need for a separator. See GetUniqueTextKey 1067 | Next colIndex 1068 | GetRowKey = rowKey 1069 | End Function 1070 | 1071 | '******************************************************************************* 1072 | 'Receives an iterable list of values via a variant and returns a 1D array 1073 | ' containing all the unique values 1074 | 'Parameters: 1075 | ' - iterableList: an array, collection or other object that can be iterated 1076 | ' using a For Each... Next loop 1077 | ' - [outLowBound]: the start index of the result array. Default is 0 1078 | 'Raises error: 1079 | ' - 5: if 'iterableList' does not support For Each... Next loop 1080 | '******************************************************************************* 1081 | Public Function GetUniqueValues(ByRef iterableList As Variant _ 1082 | , Optional ByVal outLowBound As Long = 0) As Variant() 1083 | Const fullMethodName As String = MODULE_NAME & ".GetUniqueValues" 1084 | ' 1085 | 'Check Input 1086 | If Not IsIterable(iterableList) Then 1087 | Err.Raise 5, fullMethodName, "Variant doesn't support For Each... Next" 1088 | End If 1089 | ' 1090 | Dim v As Variant 1091 | Dim collUnique As New Collection 1092 | Dim keyValue As String 1093 | ' 1094 | On Error Resume Next 'Ignore duplicates 1095 | For Each v In iterableList 1096 | keyValue = GetUniqueTextKey(v) 'Ignores Arrays and UDTs 1097 | If LenB(keyValue) > 0 Then collUnique.Add v, keyValue 1098 | Next v 1099 | On Error GoTo 0 1100 | GetUniqueValues = CollectionTo1DArray(collUnique, outLowBound) 1101 | End Function 1102 | 1103 | '******************************************************************************* 1104 | 'Returns a unique key for a Variant value by combining the value and data type 1105 | ' - For objects it uses the pointer returned by ObjPtr (using base interface) 1106 | ' - Arrays and User Defined Types (UDTs) are not supported (returns "") 1107 | ' - For other types it distinguishes by adding a trailing value based on type 1108 | '******************************************************************************* 1109 | Private Function GetUniqueTextKey(ByRef v As Variant) As String 1110 | Dim obj As IUnknown 'the fundamental interface in COM 1111 | ' 1112 | If IsObject(v) Then 1113 | Set obj = v 1114 | GetUniqueTextKey = ObjPtr(obj) 1115 | Exit Function 1116 | End If 1117 | ' 1118 | Select Case VarType(v) 1119 | Case vbNull: GetUniqueTextKey = "Null_0" 1120 | Case vbEmpty: GetUniqueTextKey = "Empty_1" 1121 | Case vbError: GetUniqueTextKey = CStr(v) & "_2" 1122 | Case vbBoolean: GetUniqueTextKey = CStr(v) & "_3" 1123 | Case vbString: GetUniqueTextKey = CStr(v) & "_4" 1124 | Case vbDate: GetUniqueTextKey = CStr(CDbl(v)) & "_5" 1125 | Case vbByte, vbInteger, vbLong, vbLongLong 'Integer 1126 | GetUniqueTextKey = CStr(v) & "_5" 1127 | Case vbCurrency, vbDecimal, vbDouble, vbSingle 'Decimal-point 1128 | GetUniqueTextKey = CStr(v) & "_5" 1129 | Case vbDataObject 1130 | Set obj = v 1131 | GetUniqueTextKey = ObjPtr(obj) 1132 | Case Else: Exit Function 'Array/UDT 1133 | End Select 1134 | End Function 1135 | 1136 | '******************************************************************************* 1137 | 'Inserts rows in a 2D array before the specified row 1138 | 'Parameters: 1139 | ' - arr: a 2D array to insert into 1140 | ' - rowsCount: the number of rows to insert 1141 | ' - beforeRow: the index of the row before which rows will be inserted 1142 | 'Raises error: 1143 | ' - 5 if: 1144 | ' * array is not two-dimensional 1145 | ' * beforeRow index or rowsCount is invalid 1146 | '******************************************************************************* 1147 | Public Function InsertRowsAtIndex(ByRef arr As Variant _ 1148 | , ByVal rowsCount As Long _ 1149 | , ByVal beforeRow As Long) As Variant 1150 | Const fullMethodName As String = MODULE_NAME & ".InsertRowsAtIndex" 1151 | ' 1152 | 'Check Input 1153 | If GetArrayDimsCount(arr) <> 2 Then 1154 | Err.Raise 5, fullMethodName, "Array is not two-dimensional" 1155 | ElseIf beforeRow < LBound(arr, 1) Or beforeRow > UBound(arr, 1) + 1 Then 1156 | Err.Raise 5, fullMethodName, "Invalid beforeRow index" 1157 | ElseIf rowsCount < 0 Then 1158 | Err.Raise 5, fullMethodName, "Invalid rows count" 1159 | ElseIf rowsCount = 0 Then 1160 | InsertRowsAtIndex = arr 1161 | Exit Function 1162 | End If 1163 | ' 1164 | 'Store Bounds for the input array 1165 | Dim loRowBound As Long: loRowBound = LBound(arr, 1) 1166 | Dim upRowBound As Long: upRowBound = UBound(arr, 1) 1167 | Dim loColBound As Long: loColBound = LBound(arr, 2) 1168 | Dim upColBound As Long: upColBound = UBound(arr, 2) 1169 | ' 1170 | Dim res() As Variant 1171 | Dim i As Long 1172 | Dim j As Long 1173 | Dim newRow As Long 1174 | Dim v As Variant 1175 | ' 1176 | 'Create a new array with the required rows 1177 | ReDim res(loRowBound To upRowBound + rowsCount, loColBound To upColBound) 1178 | ' 1179 | 'Copy values to the result array 1180 | i = loRowBound 1181 | j = loColBound 1182 | For Each v In arr 1183 | If i < beforeRow Then newRow = i Else newRow = i + rowsCount 1184 | If IsObject(v) Then Set res(newRow, j) = v Else res(newRow, j) = v 1185 | If i = upRowBound Then 'Switch to the next column 1186 | j = j + 1 1187 | i = loRowBound 1188 | Else 1189 | i = i + 1 1190 | End If 1191 | Next v 1192 | ' 1193 | InsertRowsAtIndex = res 1194 | End Function 1195 | 1196 | '******************************************************************************* 1197 | 'Inserts rows in a 2D Array between rows with different values (on the specified 1198 | ' column) and optionally at the top and/or bottom of the array 1199 | 'Parameters: 1200 | ' - arr: a 2D array to insert into 1201 | ' - rowsCount: the number of rows to insert 1202 | ' - columnIndex: the index of the column used for row comparison 1203 | ' - [topRowsCount]: number of rows to insert before array. Default is 0 1204 | ' - [bottomRowsCount]: number of rows to insert after array. Default is 0 1205 | 'Raises error: 1206 | ' - 5 if: 1207 | ' * array is not two-dimensional 1208 | ' * columnIndex/rowsCount/topRowsCount/bottomRowsCount is invalid 1209 | '******************************************************************************* 1210 | Public Function InsertRowsAtValChange(ByRef arr As Variant _ 1211 | , ByVal rowsCount As Long _ 1212 | , ByVal columnIndex As Long _ 1213 | , Optional ByVal topRowsCount As Long = 0 _ 1214 | , Optional ByVal bottomRowsCount As Long = 0) As Variant 1215 | Const fullMethodName As String = MODULE_NAME & ".InsertRowsAtValChange" 1216 | ' 1217 | 'Check Input 1218 | If GetArrayDimsCount(arr) <> 2 Then 1219 | Err.Raise 5, fullMethodName, "Expected 2D Array" 1220 | ElseIf columnIndex < LBound(arr, 2) Or columnIndex > UBound(arr, 2) Then 1221 | Err.Raise 5, fullMethodName, "Invalid column index for comparison" 1222 | ElseIf rowsCount < 0 Or topRowsCount < 0 Or bottomRowsCount < 0 Then 1223 | Err.Raise 5, fullMethodName, "Invalid rows count" 1224 | ElseIf rowsCount = 0 And topRowsCount = 0 And bottomRowsCount = 0 Then 1225 | InsertRowsAtValChange = arr 1226 | Exit Function 1227 | End If 1228 | ' 1229 | 'Store Bounds for the input array 1230 | Dim lowRow As Long: lowRow = LBound(arr, 1) 1231 | Dim uppRow As Long: uppRow = UBound(arr, 1) 1232 | Dim lowCol As Long: lowCol = LBound(arr, 2) 1233 | Dim uppCol As Long: uppCol = UBound(arr, 2) 1234 | ' 1235 | Dim arrNewRows() As Long: ReDim arrNewRows(lowRow To uppRow) 1236 | Dim i As Long 1237 | Dim n As Long 1238 | Dim currentKey As String 1239 | Dim previousKey As String 1240 | Dim rowsToInsert As Long 1241 | ' 1242 | 'Store new row indexes 1243 | previousKey = GetUniqueTextKey(arr(lowRow, columnIndex)) 1244 | n = lowRow + topRowsCount 1245 | For i = lowRow To uppRow 1246 | currentKey = GetUniqueTextKey(arr(i, columnIndex)) 1247 | If currentKey <> previousKey Then n = n + rowsCount 1248 | arrNewRows(i) = n 1249 | ' 1250 | n = n + 1 1251 | previousKey = currentKey 1252 | Next i 1253 | ' 1254 | rowsToInsert = arrNewRows(uppRow) - uppRow + bottomRowsCount 1255 | If rowsToInsert = 0 Then 1256 | InsertRowsAtValChange = arr 1257 | Exit Function 1258 | End If 1259 | ' 1260 | Dim res() As Variant 1261 | ReDim res(lowRow To uppRow + rowsToInsert, lowCol To uppCol) 1262 | Dim j As Long 1263 | Dim needSet As Boolean 1264 | ' 1265 | 'Copy values to the result array 1266 | For i = lowRow To uppRow 1267 | n = arrNewRows(i) 1268 | For j = lowCol To uppCol 1269 | needSet = IsObject(arr(i, j)) 1270 | If needSet Then Set res(n, j) = arr(i, j) Else res(n, j) = arr(i, j) 1271 | Next j 1272 | Next i 1273 | ' 1274 | InsertRowsAtValChange = res 1275 | End Function 1276 | 1277 | '******************************************************************************* 1278 | 'Returns a 1D array of consecutive Long Integer values 1279 | 'Parameters: 1280 | ' - startValue: the first value 1281 | ' - endValue: the last value 1282 | ' - [outLowBound]: the start index of the result array. Default is 0 1283 | 'Does not raise errors 1284 | '******************************************************************************* 1285 | Public Function IntegerRange1D(ByVal startValue As Long _ 1286 | , ByVal endValue As Long _ 1287 | , Optional ByVal outLowBound As Long = 0) As Long() 1288 | Dim diff As Long: diff = endValue - startValue 1289 | Dim arr() As Long: ReDim arr(outLowBound To outLowBound + Math.Abs(diff)) 1290 | Dim step_ As Long: step_ = Math.Sgn(diff) 1291 | Dim i As Long 1292 | Dim v As Long: v = startValue 1293 | ' 1294 | For i = LBound(arr) To UBound(arr) 1295 | arr(i) = v 1296 | v = v + step_ 1297 | Next i 1298 | IntegerRange1D = arr 1299 | End Function 1300 | 1301 | '******************************************************************************* 1302 | 'Checks if a specified row, in a 2D array, has no values 1303 | 'Parameters: 1304 | ' - arr: a 2D array 1305 | ' - rowIndex: the index of the row to check if is empty 1306 | ' - [ignoreEmptyStrings]: 1307 | ' * True - Empty String values are considered Empty 1308 | ' * False - Empty String values are not considered Empty. Default 1309 | 'Raises error: 1310 | ' - 5 if: 1311 | ' * the input array is not 2-dimensional 1312 | ' * the row index is out of bounds 1313 | '******************************************************************************* 1314 | Public Function Is2DArrayRowEmpty(ByRef arr As Variant _ 1315 | , ByVal rowIndex As Long _ 1316 | , Optional ByVal ignoreEmptyStrings As Boolean = False) As Boolean 1317 | Const fullMethodName As String = MODULE_NAME & ".Is2DArrayRowEmpty" 1318 | ' 1319 | 'Check Input 1320 | If GetArrayDimsCount(arr) <> 2 Then 1321 | Err.Raise 5, fullMethodName, "Array is not two-dimensional" 1322 | ElseIf rowIndex < LBound(arr, 1) Or rowIndex > UBound(arr, 1) Then 1323 | Err.Raise 5, fullMethodName, "Row Index out of bounds" 1324 | End If 1325 | ' 1326 | Dim j As Long 1327 | Dim v As Variant 1328 | ' 1329 | 'Exit Function if any non-Empty value is found (returns False) 1330 | For j = LBound(arr, 2) To UBound(arr, 2) 1331 | If IsObject(arr(rowIndex, j)) Then Exit Function 1332 | v = arr(rowIndex, j) 1333 | Select Case VarType(v) 1334 | Case VbVarType.vbEmpty 1335 | 'Continue to next element 1336 | Case VbVarType.vbString 1337 | If Not ignoreEmptyStrings Then Exit Function 1338 | If LenB(v) > 0 Then Exit Function 1339 | Case Else 1340 | Exit Function 1341 | End Select 1342 | Next j 1343 | ' 1344 | Is2DArrayRowEmpty = True 'If code reached this line then row is Empty 1345 | End Function 1346 | 1347 | '******************************************************************************* 1348 | 'Checks if a Variant is iterable using a For Each... Next loop 1349 | 'Compatible types: Arrays, Collections, Custom Collections, Dictionaries etc. 1350 | 'Does not raise errors 1351 | '******************************************************************************* 1352 | Public Function IsIterable(ByRef list_ As Variant) As Boolean 1353 | Dim v As Variant 1354 | ' 1355 | 'Custom collections classes that use Attribute NewEnum.VB_UserMemID = -4 (to 1356 | ' get a default enumerator to be used with For Each... constructions) are 1357 | ' causing automation errors and crashes on x64 1358 | 'Avoid bug by using a 'Set' statement or by using a call to another method 1359 | Set v = Nothing 1360 | ' 1361 | On Error Resume Next 1362 | For Each v In list_ 1363 | Exit For 1364 | Next v 1365 | IsIterable = (Err.Number = 0) 1366 | On Error GoTo 0 1367 | End Function 1368 | 1369 | '******************************************************************************* 1370 | 'Returns a boolean indicating if a value passes a filter 1371 | 'Parameters: 1372 | ' - value_: the target value to check against the filter 1373 | ' - filter: a FILTER_PAIR struct (operator and compare value) 1374 | 'Raises error: 1375 | ' - 5 if: 1376 | ' * filter's operator is invalid 1377 | ' * if target value or compare value are User Defined Types 1378 | ' * values are incompatible with the operator 1379 | ' * values are of incompatible data type 1380 | ' * a compare value is an array but it is not iterable 1381 | 'Notes: 1382 | ' - the filter's compare value can be a list (array, collection) 1383 | ' - IN and NOT IN operators will also work if the right member is just a 1384 | ' primitive value by switching to EQUAL and respectively NOT EQUAL 1385 | ' - LIKE and NOT LIKE operators only work if the compare value is a text 1386 | ' (pattern) and the target value is one of: bool, number, text 1387 | '******************************************************************************* 1388 | Public Function IsValuePassingFilter(ByRef value_ As Variant _ 1389 | , ByRef filter As FILTER_PAIR) As Boolean 1390 | Const fullMethodName As String = MODULE_NAME & ".IsValuePassingFilter" 1391 | Dim rnk As DATA_TYPE_RANK: rnk = GetDataTypeRank(value_) 1392 | Dim isListOperator As Boolean 1393 | ' 1394 | isListOperator = (filter.cOperator = opin) Or (filter.cOperator = opNotIn) 1395 | ' 1396 | 'Validate input 1397 | If filter.cOperator < [_opMin] Or filter.cOperator > [_opMax] Then 1398 | Err.Raise 5, fullMethodName, "Invalid Filter Operator" 1399 | ElseIf rnk = rankUDT Or filter.compValue.rank_ = rankUDT Then 1400 | Err.Raise 5, fullMethodName, "User Defined Types not supported" 1401 | ElseIf rnk = rankArray Then 1402 | IsValuePassingFilter = (filter.cOperator = opNotIn) _ 1403 | Or (filter.cOperator = opNotEqual) 1404 | Exit Function 1405 | ElseIf filter.compValue.rank_ = rankArray Then 1406 | If filter.compValue.isIterable_ Then 1407 | If Not isListOperator Then 1408 | Err.Raise 5, fullMethodName, "Incompatible filter" 1409 | End If 1410 | Else 1411 | Err.Raise 5, fullMethodName, "Compare Array is not iterable" 1412 | End If 1413 | End If 1414 | ' 1415 | 'Treat Empty as Null String by adjusting ranks 1416 | If rnk = rankEmpty Then rnk = rankText 1417 | If filter.compValue.rank_ = rankEmpty Then filter.compValue.rank_ = rankText 1418 | ' 1419 | 'Check for list inclusion 1420 | If isListOperator And filter.compValue.isIterable_ Then 1421 | Dim isIncluded As Boolean 1422 | Dim textKey As String: textKey = GetUniqueTextKey(value_) 1423 | ' 1424 | isIncluded = CollectionHasKey(filter.compValue.textKeys_, textKey) 1425 | IsValuePassingFilter = isIncluded Xor (filter.cOperator = opNotIn) 1426 | Exit Function 1427 | Else 1428 | 'Adjust inclusion operators because compare value is not iterable 1429 | If filter.cOperator = opin Then filter.cOperator = opEqual 1430 | If filter.cOperator = opNotIn Then filter.cOperator = opNotEqual 1431 | End If 1432 | ' 1433 | 'Check target value against filter 1434 | Select Case filter.cOperator 1435 | Case opSmaller, opBigger, opSmallerOrEqual, opBiggerOrEqual 1436 | If rnk <> filter.compValue.rank_ Then Exit Function 1437 | If rnk < rankBoolean Then Exit Function 1438 | ' 1439 | Select Case filter.cOperator 1440 | Case opSmaller 1441 | IsValuePassingFilter = (value_ < filter.compValue.value_) 1442 | Case opBigger 1443 | IsValuePassingFilter = (value_ > filter.compValue.value_) 1444 | Case opSmallerOrEqual 1445 | IsValuePassingFilter = (value_ <= filter.compValue.value_) 1446 | Case opBiggerOrEqual 1447 | IsValuePassingFilter = (value_ >= filter.compValue.value_) 1448 | End Select 1449 | ' 1450 | 'Force False < True. In VBA: False > True (0 > -1) 1451 | If rnk = rankBoolean Then 1452 | Dim areDifferent As Boolean 1453 | areDifferent = (value_ <> filter.compValue.value_) 1454 | IsValuePassingFilter = IsValuePassingFilter Xor areDifferent 1455 | End If 1456 | Case opLike, opNotLike 1457 | If filter.compValue.rank_ <> rankText Then Exit Function 'Text Pattern 1458 | If rnk < rankBoolean Then Exit Function 1459 | ' 1460 | 'The 'Like' operator uses Option Compare Text (see top of the module) 1461 | Dim isLike As Boolean: isLike = (value_ Like filter.compValue.value_) 1462 | IsValuePassingFilter = isLike Xor (filter.cOperator = opNotLike) 1463 | Case opEqual, opNotEqual 1464 | If rnk <> filter.compValue.rank_ Then 1465 | IsValuePassingFilter = (filter.cOperator = opNotEqual) 1466 | Exit Function 1467 | End If 1468 | ' 1469 | Dim areEqual As Boolean 1470 | ' 1471 | If rnk = rankNull Then 1472 | areEqual = True 1473 | ElseIf rnk = rankObject Then 1474 | Dim key1 As String: key1 = GetUniqueTextKey(value_) 1475 | Dim key2 As String: key2 = GetUniqueTextKey(filter.compValue.value_) 1476 | areEqual = (key1 = key2) 1477 | Else 1478 | areEqual = (value_ = filter.compValue.value_) 1479 | End If 1480 | ' 1481 | IsValuePassingFilter = areEqual Xor (filter.cOperator = opNotEqual) 1482 | Case Else 1483 | Err.Raise 5, fullMethodName, "Invalid Operator" 1484 | End Select 1485 | End Function 1486 | 1487 | '******************************************************************************* 1488 | 'Merges/Combines two 1D arrays into a new 1D array 1489 | 'Parameters: 1490 | ' - arr1: the first 1D array 1491 | ' - arr2: the second 1D array 1492 | ' - [outLowBound]: the start index of the result array. Default is 0 1493 | 'Raises error: 1494 | ' - 5 if any of the two arrays is not 1D 1495 | 'Note: 1496 | ' - if you wish to merge two 1D arrays vertically, convert them first to 2D 1497 | ' and then use the 'Merge2DArrays' method 1498 | 'Examples: 1499 | ' - arr1 = [1,2] and arr2 = [3,4,5] >> results [1,2,3,4,5] 1500 | '******************************************************************************* 1501 | Public Function Merge1DArrays(ByRef arr1 As Variant _ 1502 | , ByRef arr2 As Variant _ 1503 | , Optional ByVal outLowBound As Long = 0) As Variant 1504 | Const fullMethodName As String = MODULE_NAME & ".Merge1DArrays" 1505 | ' 1506 | 'Check Dimensions 1507 | If GetArrayDimsCount(arr1) <> 1 Or GetArrayDimsCount(arr2) <> 1 Then 1508 | Err.Raise 5, fullMethodName, "Expected 1D Arrays" 1509 | End If 1510 | ' 1511 | Dim elemCount1 As Long: elemCount1 = UBound(arr1, 1) - LBound(arr1, 1) + 1 1512 | Dim elemCount2 As Long: elemCount2 = UBound(arr2, 1) - LBound(arr2, 1) + 1 1513 | ' 1514 | 'Check for zero-length arrays 1515 | If elemCount1 = 0 Then 1516 | If LBound(arr2) = outLowBound Then 1517 | Merge1DArrays = arr2 1518 | Exit Function 1519 | End If 1520 | End If 1521 | If elemCount2 = 0 Then 1522 | If LBound(arr1) = outLowBound Then 1523 | Merge1DArrays = arr1 1524 | Exit Function 1525 | End If 1526 | End If 1527 | ' 1528 | Dim totalCount As Long: totalCount = elemCount1 + elemCount2 1529 | If totalCount = 0 Then 1530 | Merge1DArrays = ZeroLengthArray() 1531 | Exit Function 1532 | End If 1533 | ' 1534 | Dim res() As Variant: ReDim res(outLowBound To outLowBound + totalCount - 1) 1535 | Dim i As Long 1536 | Dim v As Variant 1537 | ' 1538 | 'Copy first array 1539 | i = outLowBound 1540 | For Each v In arr1 'Column-major order 1541 | If IsObject(v) Then Set res(i) = v Else res(i) = v 1542 | i = i + 1 1543 | Next v 1544 | ' 1545 | 'Copy second array 1546 | For Each v In arr2 1547 | If IsObject(v) Then Set res(i) = v Else res(i) = v 1548 | i = i + 1 1549 | Next v 1550 | ' 1551 | Merge1DArrays = res 1552 | End Function 1553 | 1554 | '******************************************************************************* 1555 | 'Merges/Combines two 2D arrays into a new 2D array 1556 | 'Parameters: 1557 | ' - arr1: the first 2D array 1558 | ' - arr2: the second 2D array 1559 | ' - verticalMerge: 1560 | ' * True - arrays are combined vertically i.e. rows are combined 1561 | ' * False - arrays are combined horizontally i.e. columns are combined 1562 | ' - [outLowRow]: the start index of the result's 1st dimension. Default is 0 1563 | ' - [outLowCol]: the start index of the result's 2nd dimension. Default is 0 1564 | 'Raises error: 1565 | ' - 5 if: 1566 | ' * any of the two arrays is not 2D 1567 | ' * the number of rows or columns are incompatible for merging 1568 | 'Examples: 1569 | ' - arr1 = [1,2] and arr2 = [5,6] and verticalMerge = True >> results [1,2] 1570 | ' [3,4] [7,8] [3,4] 1571 | ' [5,6] 1572 | ' [7,8] 1573 | ' - arr1 = [1,2] and arr2 = [5,6] and verticalMerge = False > results [1,2,5,6] 1574 | ' [3,4] [7,8] [3,4,7,8] 1575 | '******************************************************************************* 1576 | Public Function Merge2DArrays(ByRef arr1 As Variant _ 1577 | , ByRef arr2 As Variant _ 1578 | , ByVal verticalMerge As Boolean _ 1579 | , Optional ByVal outLowRow As Long = 0 _ 1580 | , Optional ByVal outLowCol As Long = 0) As Variant() 1581 | Const fullMethodName As String = MODULE_NAME & ".Merge2DArrays" 1582 | ' 1583 | 'Check Dimensions 1584 | If GetArrayDimsCount(arr1) <> 2 Or GetArrayDimsCount(arr2) <> 2 Then 1585 | Err.Raise 5, fullMethodName, "Expected 2D Arrays" 1586 | End If 1587 | ' 1588 | Dim rowsCount1 As Long: rowsCount1 = UBound(arr1, 1) - LBound(arr1, 1) + 1 1589 | Dim rowsCount2 As Long: rowsCount2 = UBound(arr2, 1) - LBound(arr2, 1) + 1 1590 | Dim colsCount1 As Long: colsCount1 = UBound(arr1, 2) - LBound(arr1, 2) + 1 1591 | Dim colsCount2 As Long: colsCount2 = UBound(arr2, 2) - LBound(arr2, 2) + 1 1592 | Dim totalRows As Long 1593 | Dim totalCols As Long 1594 | ' 1595 | 'Check if rows/columns are compatible 1596 | If verticalMerge Then 1597 | If colsCount1 <> colsCount2 Then 1598 | Err.Raise 5, fullMethodName, "Expected same number of columns" 1599 | End If 1600 | totalRows = rowsCount1 + rowsCount2 1601 | totalCols = colsCount1 1602 | Else 'Horizontal merge 1603 | If rowsCount1 <> rowsCount2 Then 1604 | Err.Raise 5, fullMethodName, "Expected same number of rows" 1605 | End If 1606 | totalRows = rowsCount1 1607 | totalCols = colsCount1 + colsCount2 1608 | End If 1609 | ' 1610 | Dim res() As Variant: ReDim res(outLowRow To outLowRow + totalRows - 1 _ 1611 | , outLowCol To outLowCol + totalCols - 1) 1612 | Dim i As Long 1613 | Dim j As Long 1614 | Dim v As Variant 1615 | Dim r1 As Long: r1 = outLowRow + rowsCount1 1616 | ' 1617 | 'Copy first array 1618 | i = outLowRow 1619 | j = outLowCol 1620 | 'For Each... loop is faster than using 2 For... Next loops 1621 | For Each v In arr1 'Column-major order 1622 | If IsObject(v) Then Set res(i, j) = v Else res(i, j) = v 1623 | i = i + 1 1624 | If i = r1 Then 'Switch to the next column 1625 | j = j + 1 1626 | i = outLowRow 1627 | End If 1628 | Next v 1629 | ' 1630 | Dim r2 As Long: r2 = outLowRow + totalRows 1631 | Dim s2 As Long: s2 = r2 - rowsCount2 1632 | ' 1633 | 'Copy second array 1634 | i = s2 1635 | j = outLowCol + totalCols - colsCount2 1636 | For Each v In arr2 1637 | If IsObject(v) Then Set res(i, j) = v Else res(i, j) = v 1638 | i = i + 1 1639 | If i = r2 Then 'Switch to the next column 1640 | j = j + 1 1641 | i = s2 1642 | End If 1643 | Next v 1644 | ' 1645 | Merge2DArrays = res 1646 | End Function 1647 | 1648 | '******************************************************************************* 1649 | 'Converts a multidimensional array to a 1 dimension array 1650 | 'Parameters: 1651 | ' - arr: the array to convert 1652 | ' - traverseType: read arr elements in row-wise or column-wise order 1653 | 'Notes: 1654 | ' * Invalid traverseType values are defaulted to column-wise order 1655 | 'Examples: 1656 | ' - arr = [1,2] and traverseType = columnWise >> results [1,3,2,4] 1657 | ' [3,4] 1658 | ' - arr = [1,2] and traverseType = rowWise >> results [1,2,3,4] 1659 | ' [3,4] 1660 | '******************************************************************************* 1661 | Public Function NDArrayTo1DArray(ByRef arr As Variant _ 1662 | , ByVal traverseType As ARRAY_TRAVERSE_TYPE) As Variant 1663 | Const fullMethodName As String = MODULE_NAME & ".NDArrayTo1DArray" 1664 | ' 1665 | 'Check Array Dimensions 1666 | Select Case GetArrayDimsCount(arr) 1667 | Case 0 1668 | Err.Raise 5, fullMethodName, "Invalid or Uninitialized Array" 1669 | Case 1 1670 | NDArrayTo1DArray = arr 1671 | Case Else 1672 | Dim trType As ARRAY_TRAVERSE_TYPE 1673 | ' 1674 | If traverseType = rowWise Then trType = rowWise Else trType = columnWise 1675 | NDArrayTo1DArray = GetArrayDescriptor(arr, trType, True).elements1D 1676 | End Select 1677 | End Function 1678 | 1679 | '******************************************************************************* 1680 | 'Builds and returns an ARRAY_DESCRIPTOR structure for the specified array 1681 | 'Parameters: 1682 | ' - arr: the array used to generate the custom structure 1683 | ' - traverseType: read array elements in row-wise or column-wise order 1684 | ' - addElements1D: populates the ".elements1D" array for the ARRAY_DESCRIPTOR 1685 | '******************************************************************************* 1686 | Private Function GetArrayDescriptor(ByRef arr As Variant _ 1687 | , ByVal traverseType As ARRAY_TRAVERSE_TYPE _ 1688 | , ByVal addElements1D As Boolean) As ARRAY_DESCRIPTOR 1689 | Dim descStruct As ARRAY_DESCRIPTOR 1690 | Dim i As Long 1691 | ' 1692 | 'Prepare Struct for looping 1693 | With descStruct 1694 | .dimsCount = GetArrayDimsCount(arr) 1695 | ReDim .dimensions(1 To .dimsCount) 1696 | .elemCount = 1 'Start value. Can turn into 0 if array is zero-length 1697 | .traverseType = traverseType 1698 | End With 1699 | ' 1700 | 'Loop through the array dimensions and store the size of each dimension, the 1701 | ' depth of each dimension (the product of lower dimension sizes) and the 1702 | ' total count of elements in the entire array 1703 | For i = descStruct.dimsCount To 1 Step -1 1704 | With descStruct.dimensions(i) 1705 | .index = i 1706 | .depth = descStruct.elemCount 1707 | .size = UBound(arr, i) - LBound(arr, i) + 1 1708 | descStruct.elemCount = descStruct.elemCount * .size 1709 | End With 1710 | Next i 1711 | ' 1712 | 'Populate elements as a 1-dimensional array (vector) 1713 | If addElements1D Then AddElementsToDescriptor descStruct, arr 1714 | ' 1715 | GetArrayDescriptor = descStruct 1716 | End Function 1717 | 1718 | '******************************************************************************* 1719 | 'Populates the ".elements1D" array for an ARRAY_DESCRIPTOR Structure 1720 | 'Parameters: 1721 | ' - descStruct: the structure to populate 1722 | ' - sourceArray: the multidimensional array containing the elements 1723 | '******************************************************************************* 1724 | Private Sub AddElementsToDescriptor(ByRef descStruct As ARRAY_DESCRIPTOR _ 1725 | , ByRef sourceArray As Variant) 1726 | 'Note that zero-length arrays (1 dimension) are covered as well 1727 | If descStruct.dimsCount = 1 Then 1728 | descStruct.elements1D = sourceArray 1729 | Exit Sub 1730 | End If 1731 | ' 1732 | 'Size the elements vector 1733 | ReDim descStruct.elements1D(0 To descStruct.elemCount - 1) 1734 | ' 1735 | Dim tempElement As Variant 1736 | Dim i As Long: i = 0 1737 | ' 1738 | 'Populate target, element by element 1739 | If descStruct.traverseType = rowWise Then 1740 | Dim rowMajorIndex As Long 1741 | ' 1742 | With descStruct 1743 | ReDim .rowMajorIndexes(1 To .elemCount) 1744 | AddRowMajorIndexes descStruct, .dimensions(.dimsCount), 1, 1 1745 | End With 1746 | For Each tempElement In sourceArray 1747 | i = i + 1 1748 | rowMajorIndex = descStruct.rowMajorIndexes(i) - 1 1749 | If IsObject(tempElement) Then 1750 | Set descStruct.elements1D(rowMajorIndex) = tempElement 1751 | Else 1752 | descStruct.elements1D(rowMajorIndex) = tempElement 1753 | End If 1754 | Next tempElement 1755 | Else 'columnWise - VBA already stores arrays in columnMajorOrder 1756 | For Each tempElement In sourceArray 1757 | If IsObject(tempElement) Then 1758 | Set descStruct.elements1D(i) = tempElement 1759 | Else 1760 | descStruct.elements1D(i) = tempElement 1761 | End If 1762 | i = i + 1 1763 | Next tempElement 1764 | End If 1765 | End Sub 1766 | 1767 | '******************************************************************************* 1768 | 'Populates the "rowMajorIndexes" array for an ARRAY_DESCRIPTOR Structure 1769 | 'Recursive! 1770 | 'Parameters: 1771 | ' - descStruct: the details structure. See ARRAY_DESCRIPTOR custom type 1772 | ' - currDimension: the current dimension that the function is working on. 1773 | ' In the initial call it must be the last dimension (lowest) 1774 | ' - colWiseIndex: first element (current dimension) column-major index 1775 | ' In the initial call must have the value of 1 1776 | ' - rowWiseIndex: element row-major index implemented as a counter (ByRef) 1777 | ' In the initial call must have the value of 1 1778 | '******************************************************************************* 1779 | Private Sub AddRowMajorIndexes(ByRef descStruct As ARRAY_DESCRIPTOR _ 1780 | , ByRef currDimension As ARRAY_DIMENSION _ 1781 | , ByVal colWiseIndex As Long _ 1782 | , ByRef rowWiseIndex As Long) 1783 | Dim i As Long 1784 | Dim tempIndex As Long 1785 | ' 1786 | If currDimension.index = 1 Then 'First dimension (highest). Populate Indexes 1787 | For i = 0 To currDimension.size - 1 1788 | tempIndex = colWiseIndex + i * currDimension.depth 1789 | descStruct.rowMajorIndexes(rowWiseIndex) = tempIndex 1790 | rowWiseIndex = rowWiseIndex + 1 1791 | Next i 1792 | Else 'Pass colWise and rowWise indexes to higher dimensions 1793 | Dim prevDim As ARRAY_DIMENSION 1794 | ' 1795 | prevDim = descStruct.dimensions(currDimension.index - 1) 1796 | For i = 0 To currDimension.size - 1 1797 | tempIndex = colWiseIndex + i * currDimension.depth 1798 | AddRowMajorIndexes descStruct, prevDim, tempIndex, rowWiseIndex 1799 | Next i 1800 | End If 1801 | End Sub 1802 | 1803 | '******************************************************************************* 1804 | 'Multidimensional array to collections 1805 | 'Mimics the way arrays are stored in other languages (vectors inside vectors) 1806 | ' except that the indexes will start with 1 instead of 0 (VBA Collections) 1807 | '******************************************************************************* 1808 | Public Function NDArrayToCollections(ByRef arr As Variant) As Collection 1809 | Const fullMethodName As String = MODULE_NAME & ".NDArrayToCollections" 1810 | ' 1811 | If GetArrayDimsCount(arr) = 0 Then 1812 | Err.Raise 5, fullMethodName, "Invalid or Uninitialized Array" 1813 | End If 1814 | ' 1815 | Dim descStruct As ARRAY_DESCRIPTOR 1816 | descStruct = GetArrayDescriptor(arr, rowWise, True) 1817 | ' 1818 | Set NDArrayToCollections = GetCollsFromDescriptor( _ 1819 | descStruct, descStruct.dimensions(1), LBound(descStruct.elements1D)) 1820 | End Function 1821 | 1822 | '******************************************************************************* 1823 | 'Returns nested Collections using the descriptor of a multidimensional Array 1824 | 'Recursive! 1825 | 'Parameters: 1826 | ' - descStruct: the descriptor structure 1827 | ' - currDimension: the current dimension that the function is working on. 1828 | ' In the initial call must be the first dimension (highest) 1829 | ' - elemIndex: element index implemented as a counter (ByRef). 1830 | ' In the initial call must be LBound of 'descStruct.elements1D' 1831 | '******************************************************************************* 1832 | Private Function GetCollsFromDescriptor(ByRef descStruct As ARRAY_DESCRIPTOR _ 1833 | , ByRef currDimension As ARRAY_DIMENSION _ 1834 | , ByRef elemIndex As Long) As Collection 1835 | Dim collResult As New Collection 1836 | Dim i As Long 1837 | ' 1838 | If currDimension.index = descStruct.dimsCount Then 1839 | 'Last dimension (lowest). Populate Elements 1840 | For i = 1 To currDimension.size 1841 | collResult.Add descStruct.elements1D(elemIndex) 1842 | elemIndex = elemIndex + 1 1843 | Next i 1844 | Else 'Get Collections for lower dimensions 1845 | Dim nextDim As ARRAY_DIMENSION 1846 | ' 1847 | nextDim = descStruct.dimensions(currDimension.index + 1) 1848 | For i = 1 To currDimension.size 1849 | collResult.Add GetCollsFromDescriptor(descStruct, nextDim, elemIndex) 1850 | Next i 1851 | End If 1852 | ' 1853 | Set GetCollsFromDescriptor = collResult 1854 | End Function 1855 | 1856 | '******************************************************************************* 1857 | 'Returns a 2D array based on values contained in the specified 1D array 1858 | 'Parameters: 1859 | ' - arr: the 1D array that contains the values to be used 1860 | ' - columnsCount: the number of columns that the result 2D array will have 1861 | 'Raises error: 1862 | ' - 5 if: 1863 | ' * input array is not 1D 1864 | ' * input array has no elements i.e. zero-length array 1865 | ' * the number of columns is less than 1 1866 | 'Notes: 1867 | ' - if the total Number of values is not divisible by columnsCount then the 1868 | ' extra values (last row) of the array are by default the value Empty 1869 | '******************************************************************************* 1870 | Public Function OneDArrayTo2DArray(ByRef arr As Variant _ 1871 | , ByVal columnsCount As Long) As Variant() 1872 | Const fullMethodName As String = MODULE_NAME & ".OneDArrayTo2DArray" 1873 | ' 1874 | 'Check Input 1875 | If GetArrayDimsCount(arr) <> 1 Then 1876 | Err.Raise 5, fullMethodName, "Expected 1D Array" 1877 | ElseIf LBound(arr) > UBound(arr) Then 1878 | Err.Raise 5, fullMethodName, "Zero-length array. No elements" 1879 | ElseIf columnsCount < 1 Then 1880 | Err.Raise 5, fullMethodName, "Invalid Columns Count" 1881 | End If 1882 | ' 1883 | Dim elemCount As Long: elemCount = UBound(arr) - LBound(arr) + 1 1884 | Dim rowsCount As Long: rowsCount = -Int(-elemCount / columnsCount) 1885 | Dim res() As Variant 1886 | Dim i As Long: i = 0 1887 | Dim r As Long 1888 | Dim c As Long 1889 | Dim v As Variant 1890 | ' 1891 | 'Populate result array 1892 | ReDim res(0 To rowsCount - 1, 0 To columnsCount - 1) 1893 | For Each v In arr 1894 | r = i \ columnsCount 1895 | c = i Mod columnsCount 1896 | If IsObject(v) Then Set res(r, c) = v Else res(r, c) = v 1897 | i = i + 1 1898 | Next v 1899 | ' 1900 | OneDArrayTo2DArray = res 1901 | End Function 1902 | 1903 | '******************************************************************************* 1904 | 'Returns a collection based on values contained in the specified 1D array 1905 | 'Parameters: 1906 | ' - arr: the 1D array that contains the values to be used 1907 | 'Raises error: 1908 | ' - 5 if: input array is not 1D 1909 | '******************************************************************************* 1910 | Public Function OneDArrayToCollection(ByRef arr As Variant) As Collection 1911 | Const fullMethodName As String = MODULE_NAME & ".OneDArrayToCollection" 1912 | ' 1913 | 'Check Input 1914 | If GetArrayDimsCount(arr) <> 1 Then 1915 | Err.Raise 5, fullMethodName, "Expected 1D Array" 1916 | End If 1917 | ' 1918 | Dim coll As New Collection 1919 | Dim v As Variant 1920 | ' 1921 | For Each v In arr 1922 | coll.Add v 1923 | Next v 1924 | ' 1925 | Set OneDArrayToCollection = coll 1926 | End Function 1927 | 1928 | '******************************************************************************* 1929 | 'Removes all empty rows from a 2D Array, in-place 1930 | 'Parameters: 1931 | ' - arr: a 2D array 1932 | ' - [ignoreEmptyStrings]: 1933 | ' * True - Empty String values are considered Empty 1934 | ' * False - Empty String values are not considered Empty. Default 1935 | 'Raises error: 1936 | ' - 5 if: the input array is not 2-dimensional 1937 | '******************************************************************************* 1938 | Public Sub RemoveEmptyRows(ByRef arr() As Variant _ 1939 | , Optional ByVal ignoreEmptyStrings As Boolean = False) 1940 | Const fullMethodName As String = MODULE_NAME & ".RemoveEmptyRows" 1941 | If GetArrayDimsCount(arr) <> 2 Then 1942 | Err.Raise 5, fullMethodName, "Expected 2D Array" 1943 | End If 1944 | ' 1945 | Dim collRows As New Collection 1946 | Dim lowRow As Long: lowRow = LBound(arr, 1) 1947 | Dim uppRow As Long: uppRow = UBound(arr, 1) 1948 | Dim i As Long 1949 | ' 1950 | For i = lowRow To uppRow 1951 | If Not Is2DArrayRowEmpty(arr, i, ignoreEmptyStrings) Then 1952 | collRows.Add i 1953 | End If 1954 | Next i 1955 | ' 1956 | If collRows.Count = 0 Then 1957 | arr = ZeroLengthArray() 1958 | ElseIf collRows.Count <> uppRow - lowRow + 1 Then 1959 | Dim arrTemp() As Variant 1960 | Dim v As Variant 1961 | Dim j As Long 1962 | Dim lowCol As Long: lowCol = LBound(arr, 2) 1963 | Dim uppCol As Long: uppCol = UBound(arr, 2) 1964 | Dim rowIndex As Long: rowIndex = lowRow 1965 | ' 1966 | ReDim arrTemp(lowRow To lowRow + collRows.Count - 1, lowCol To uppCol) 1967 | For Each v In collRows 1968 | i = v 1969 | For j = lowCol To uppCol 1970 | arrTemp(rowIndex, j) = arr(i, j) 1971 | Next j 1972 | rowIndex = rowIndex + 1 1973 | Next v 1974 | arr = arrTemp 1975 | End If 1976 | End Sub 1977 | 1978 | '******************************************************************************* 1979 | 'Replaces Empty values within an Array 1980 | 'Curently supports 1D, 2D and 3D arrays 1981 | '******************************************************************************* 1982 | Public Sub ReplaceEmptyInArray(ByRef arr As Variant, ByVal newVal As Variant) 1983 | Dim needsSet As Boolean: needsSet = IsObject(newVal) 1984 | Dim v As Variant 1985 | Dim i As Long 1986 | ' 1987 | Select Case GetArrayDimsCount(arr) 1988 | Case 1 1989 | i = LBound(arr, 1) 1990 | For Each v In arr 1991 | If IsEmpty(v) Then 1992 | If needsSet Then Set arr(i) = newVal Else arr(i) = newVal 1993 | End If 1994 | i = i + 1 1995 | Next v 1996 | Case 2 1997 | Dim lowerRow As Long: lowerRow = LBound(arr, 1) 1998 | Dim upperRow As Long: upperRow = UBound(arr, 1) 1999 | Dim j As Long 2000 | ' 2001 | i = lowerRow 2002 | j = LBound(arr, 2) 2003 | 'For Each... Next loop is faster than using 2 For... Next loops 2004 | For Each v In arr 'Column-major order 2005 | If IsEmpty(v) Then 2006 | If needsSet Then Set arr(i, j) = newVal Else arr(i, j) = newVal 2007 | End If 2008 | If i = upperRow Then 'Switch to the next column 2009 | j = j + 1 2010 | i = lowerRow 2011 | Else 2012 | i = i + 1 2013 | End If 2014 | Next v 2015 | Case 3 2016 | Dim k As Long 2017 | ' 2018 | For i = LBound(arr, 1) To UBound(arr, 1) 2019 | For j = LBound(arr, 2) To UBound(arr, 2) 2020 | For k = LBound(arr, 3) To UBound(arr, 3) 2021 | If IsEmpty(arr(i, j, k)) Then 2022 | If needsSet Then 2023 | Set arr(i, j, k) = newVal 2024 | Else 2025 | arr(i, j, k) = newVal 2026 | End If 2027 | End If 2028 | Next k 2029 | Next j 2030 | Next i 2031 | Case Else 2032 | 'Add logic as needed (e.g. for 4 dimensions) 2033 | End Select 2034 | End Sub 2035 | 2036 | '******************************************************************************* 2037 | 'Replaces Null values within an Array 2038 | 'Curently supports 1D, 2D and 3D arrays 2039 | '******************************************************************************* 2040 | Public Sub ReplaceNullInArray(ByRef arr As Variant, ByVal newVal As Variant) 2041 | Dim needsSet As Boolean: needsSet = IsObject(newVal) 2042 | Dim v As Variant 2043 | Dim i As Long 2044 | ' 2045 | Select Case GetArrayDimsCount(arr) 2046 | Case 1 2047 | i = LBound(arr, 1) 2048 | For Each v In arr 2049 | If IsNull(v) Then 2050 | If needsSet Then Set arr(i) = newVal Else arr(i) = newVal 2051 | End If 2052 | i = i + 1 2053 | Next v 2054 | Case 2 2055 | Dim lowerRow As Long: lowerRow = LBound(arr, 1) 2056 | Dim upperRow As Long: upperRow = UBound(arr, 1) 2057 | Dim j As Long 2058 | ' 2059 | i = lowerRow 2060 | j = LBound(arr, 2) 2061 | 'For Each... Next loop is faster than using 2 For... Next loops 2062 | For Each v In arr 'Column-major order 2063 | If IsNull(v) Then 2064 | If needsSet Then Set arr(i, j) = newVal Else arr(i, j) = newVal 2065 | End If 2066 | If i = upperRow Then 'Switch to the next column 2067 | j = j + 1 2068 | i = lowerRow 2069 | Else 2070 | i = i + 1 2071 | End If 2072 | Next v 2073 | Case 3 2074 | Dim k As Long 2075 | ' 2076 | For i = LBound(arr, 1) To UBound(arr, 1) 2077 | For j = LBound(arr, 2) To UBound(arr, 2) 2078 | For k = LBound(arr, 3) To UBound(arr, 3) 2079 | If IsNull(arr(i, j, k)) Then 2080 | If needsSet Then 2081 | Set arr(i, j, k) = newVal 2082 | Else 2083 | arr(i, j, k) = newVal 2084 | End If 2085 | End If 2086 | Next k 2087 | Next j 2088 | Next i 2089 | Case Else 2090 | 'Add logic as needed (e.g. for 4 dimensions) 2091 | End Select 2092 | End Sub 2093 | 2094 | '******************************************************************************* 2095 | 'Reverses (in groups) a 1D Array, in-place 2096 | 'Returns: 2097 | ' - the reversed 1D array 2098 | 'Parameters: 2099 | ' - arr: a 1D array of values to be reversed 2100 | ' - [groupSize]: the number of values in each group. Default is 1 2101 | 'Notes: 2102 | ' - the array is reversed in place so it is optional to use the return value 2103 | ' of the function 2104 | 'Raises error: 2105 | ' - 5 if: 2106 | ' * array is not one-dimensional 2107 | ' * array has no elements (zero-length array) 2108 | ' * groupSize is smaller than 1 2109 | ' * the number of elements is not divisible by the groupSize 2110 | 'Examples: 2111 | ' - arr = [1,2,3,4,5,6] and groupSize = 1 >> returns [6,5,4,3,2,1] 2112 | ' - arr = [1,2,3,4,5,6] and groupSize = 2 >> returns [5,6,3,4,1,2] 2113 | ' - arr = [1,2,3,4,5,6] and groupSize = 3 >> returns [4,5,6,1,2,3] 2114 | ' - arr = [1,2,3,4,5,6] and groupSize = 4 >> error 5 is raised 2115 | ' - arr = [1,2,3,4,5,6] and groupSize = 5 >> error 5 is raised 2116 | ' - arr = [1,2,3,4,5,6] and groupSize = 6 >> returns [1,2,3,4,5,6] 2117 | '******************************************************************************* 2118 | Public Function Reverse1DArray(ByRef arr As Variant _ 2119 | , Optional ByVal groupSize As Long = 1) As Variant 2120 | Const fullMethodName As String = MODULE_NAME & ".Reverse1DArray" 2121 | ' 2122 | 'Check Input 2123 | If GetArrayDimsCount(arr) <> 1 Then 2124 | Err.Raise 5, fullMethodName, "Expected 1D Array" 2125 | ElseIf LBound(arr) > UBound(arr) Then 2126 | Err.Raise 5, fullMethodName, "Zero-length array. No elements" 2127 | ElseIf groupSize < 1 Then 2128 | Err.Raise 5, fullMethodName, "Invalid GroupSize" 2129 | ElseIf (UBound(arr, 1) - LBound(arr, 1) + 1) Mod groupSize <> 0 Then 2130 | Err.Raise 5, fullMethodName, "Elements not divisible by groupSize" 2131 | End If 2132 | ' 2133 | Dim index1 As Long: index1 = LBound(arr, 1) 2134 | Dim index2 As Long: index2 = UBound(arr, 1) - groupSize + 1 2135 | Dim i As Long 2136 | ' 2137 | 'Reverse 2138 | Do While index1 < index2 2139 | For i = 1 To groupSize 2140 | Swap1DArrayValues arr, index1, index2 2141 | index1 = index1 + 1 2142 | index2 = index2 + 1 2143 | Next i 2144 | index2 = index2 - 2 * groupSize 2145 | Loop 2146 | ' 2147 | Reverse1DArray = arr 'Useful for method chaining 2148 | End Function 2149 | 2150 | '******************************************************************************* 2151 | 'Reverses (in groups) a 2D Array, in-place 2152 | 'Returns: 2153 | ' - the reversed 2D array 2154 | 'Parameters: 2155 | ' - arr: a 2D Array of values to be reversed 2156 | ' - [groupSize]: the number of values in each group. Default is 1 2157 | ' - [verticalFlip]: 2158 | ' * True - reverse vertically 2159 | ' * False - reverse horizontally (default) 2160 | 'Notes: 2161 | ' - the array is reversed in place so it is optional to use the return value 2162 | ' of the function 2163 | 'Raises error: 2164 | ' - 5 if: 2165 | ' * array is not two-dimensional 2166 | ' * groupSize is smaller than 1 2167 | ' * the number of elements is not divisible by the groupSize 2168 | 'Examples: 2169 | ' - arr = [1,2,3,4], groupSize = 2, verticalFlip = False > returns [3,4,1,2] 2170 | ' [5,6,7,8] [7,8,5,6] 2171 | ' - arr = [1,2,3,4], groupSize = 1, verticalFlip = True >> returns [5,6,7,8] 2172 | ' [5,6,7,8] [1,2,3,4] 2173 | '******************************************************************************* 2174 | Public Function Reverse2DArray(ByRef arr As Variant _ 2175 | , Optional ByVal groupSize As Long = 1 _ 2176 | , Optional ByVal verticalFlip As Boolean = False) As Variant 2177 | Const fullMethodName As String = MODULE_NAME & ".Reverse2DArray" 2178 | ' 2179 | 'Check Input 2180 | If GetArrayDimsCount(arr) <> 2 Then 2181 | Err.Raise 5, fullMethodName, "Expected 2D Array" 2182 | ElseIf groupSize < 1 Then 2183 | Err.Raise 5, fullMethodName, "Invalid GroupSize" 2184 | ElseIf verticalFlip Then 2185 | If (UBound(arr, 1) - LBound(arr, 1) + 1) Mod groupSize <> 0 Then 2186 | Err.Raise 5, fullMethodName, "Rows not divisible by groupSize" 2187 | End If 2188 | ElseIf (UBound(arr, 2) - LBound(arr, 2) + 1) Mod groupSize <> 0 Then 2189 | Err.Raise 5, fullMethodName, "Columns not divisible by groupSize" 2190 | End If 2191 | ' 2192 | Dim dimension As Long: If verticalFlip Then dimension = 1 Else dimension = 2 2193 | Dim index1 As Long: index1 = LBound(arr, dimension) 2194 | Dim index2 As Long: index2 = UBound(arr, dimension) - groupSize + 1 2195 | Dim i As Long 2196 | ' 2197 | 'Reverse rows or columns 2198 | Do While index1 < index2 2199 | For i = 1 To groupSize 2200 | If verticalFlip Then 2201 | Swap2DArrayRows arr, index1, index2 2202 | Else 2203 | Swap2DArrayColumns arr, index1, index2 2204 | End If 2205 | index1 = index1 + 1 2206 | index2 = index2 + 1 2207 | Next i 2208 | index2 = index2 - 2 * groupSize 2209 | Loop 2210 | ' 2211 | Reverse2DArray = arr 'Useful for method chaining 2212 | End Function 2213 | 2214 | '******************************************************************************* 2215 | 'Reverses a Collection, in groups, in-place 2216 | 'Returns: 2217 | ' - the reversed Collection 2218 | 'Parameters: 2219 | ' - coll: a collection of values to reverse 2220 | ' - [groupSize]: the number of values in each group. Default is 1 2221 | 'Notes: 2222 | ' - the collection is reversed in place so it is optional to use the return 2223 | ' value of the function 2224 | ' - a collection that has no elements is returned as-is 2225 | 'Raises Error: 2226 | ' - 91: if Collection Object is not set 2227 | ' - 5: if groupSize is smaller than 1 2228 | ' - 5: if the number of elements is not divisible by the groupSize 2229 | 'Examples: 2230 | ' - coll = [1,2,3,4,5,6] and groupSize = 1 >> returns [6,5,4,3,2,1] 2231 | ' - coll = [1,2,3,4,5,6] and groupSize = 2 >> returns [5,6,3,4,1,2] 2232 | ' - coll = [1,2,3,4,5,6] and groupSize = 3 >> returns [4,5,6,1,2,3] 2233 | ' - coll = [1,2,3,4,5,6] and groupSize = 4 >> error 5 is raised 2234 | ' - coll = [1,2,3,4,5,6] and groupSize = 5 >> error 5 is raised 2235 | ' - coll = [1,2,3,4,5,6] and groupSize = 6 >> returns [1,2,3,4,5,6] 2236 | '******************************************************************************* 2237 | Public Function ReverseCollection(ByVal coll As Collection _ 2238 | , Optional ByVal groupSize As Long = 1) As Collection 2239 | Const fullMethodName As String = MODULE_NAME & ".ReverseCollection" 2240 | ' 2241 | 'Check Input 2242 | If coll Is Nothing Then 2243 | Err.Raise 91, fullMethodName, "Collection not set" 2244 | ElseIf coll.Count = 0 Then 2245 | Err.Raise 5, fullMethodName, "No elements" 2246 | ElseIf groupSize < 1 Then 2247 | Err.Raise 5, fullMethodName, "Invalid GroupSize" 2248 | ElseIf coll.Count Mod groupSize <> 0 Then 2249 | Err.Raise 5, fullMethodName, "Elements not divisible by groupSize" 2250 | End If 2251 | ' 2252 | Dim index1 As Long: index1 = 1 2253 | Dim index2 As Long: index2 = coll.Count - groupSize + 1 2254 | Dim i As Long 2255 | ' 2256 | 'Reverse 2257 | Do While index1 < index2 2258 | For i = 1 To groupSize 2259 | coll.Add Item:=coll.Item(index2), Before:=index1 2260 | index1 = index1 + 1 2261 | index2 = index2 + 1 2262 | coll.Remove index2 2263 | Next i 2264 | index2 = index2 - groupSize 2265 | Loop 2266 | ' 2267 | Set ReverseCollection = coll 'Useful for method chaining 2268 | End Function 2269 | 2270 | '******************************************************************************* 2271 | 'Creates and returns an arithmetic progression sequence as a 1D array 2272 | 'Parameters: 2273 | ' - termsCount: the number of terms 2274 | ' - [initialTerm]: the value of the first term 2275 | ' - [commonDifference]: the difference between any 2 consecutive terms 2276 | 'Raises error: 2277 | ' - 5: if 'termsCount' is not at least 1 2278 | 'Theory: 2279 | ' https://en.wikipedia.org/wiki/Arithmetic_progression 2280 | '******************************************************************************* 2281 | Public Function Sequence1D(ByVal termsCount As Long _ 2282 | , Optional ByVal initialTerm As Double = 1 _ 2283 | , Optional ByVal commonDifference As Double = 1) As Double() 2284 | Const fullMethodName As String = MODULE_NAME & ".Sequence1D" 2285 | If termsCount < 1 Then Err.Raise 5, fullMethodName, "Wrong number of terms" 2286 | ' 2287 | Dim arr() As Double: ReDim arr(0 To termsCount - 1) 2288 | Dim i As Long 2289 | ' 2290 | For i = 0 To termsCount - 1 2291 | arr(i) = initialTerm + i * commonDifference 2292 | Next i 2293 | Sequence1D = arr 2294 | End Function 2295 | 2296 | '******************************************************************************* 2297 | 'Creates and returns an arithmetic progression sequence as a 2D array 2298 | 'Parameters: 2299 | ' - termsCount: the number of terms 2300 | ' - [initialTerm]: the value of the first term 2301 | ' - [commonDifference]: the difference between any 2 consecutive terms 2302 | ' - [columnsCount]: the number of columns in the output 2D Array 2303 | 'Raises error: 2304 | ' - 5 if: 2305 | ' * 'termsCount' is not at least 1 2306 | ' * 'columnsCount' is not at least 1 2307 | 'Theory: 2308 | ' https://en.wikipedia.org/wiki/Arithmetic_progression 2309 | 'Notes: 2310 | ' - if the total number of terms is not divisible by columnsCount then the 2311 | ' extra values (last row) of the array are by default 0 (zero) 2312 | '******************************************************************************* 2313 | Public Function Sequence2D(ByVal termsCount As Long _ 2314 | , Optional ByVal initialTerm As Double = 1 _ 2315 | , Optional ByVal commonDifference As Double = 1 _ 2316 | , Optional ByVal columnsCount As Long = 1) As Double() 2317 | Const fullMethodName As String = MODULE_NAME & ".Sequence2D" 2318 | If termsCount < 1 Then 2319 | Err.Raise 5, fullMethodName, "Wrong number of terms" 2320 | ElseIf columnsCount < 1 Then 2321 | Err.Raise 5, fullMethodName, "Expected at least 1 output column" 2322 | End If 2323 | ' 2324 | Dim rowsCount As Long: rowsCount = -Int(-termsCount / columnsCount) 2325 | Dim arr() As Double: ReDim arr(0 To rowsCount - 1, 0 To columnsCount - 1) 2326 | Dim r As Long 2327 | Dim c As Long 2328 | Dim i As Long 2329 | ' 2330 | For i = 0 To termsCount - 1 2331 | r = i \ columnsCount 2332 | c = i Mod columnsCount 2333 | arr(r, c) = initialTerm + i * commonDifference 2334 | Next i 2335 | Sequence2D = arr 2336 | End Function 2337 | 2338 | '******************************************************************************* 2339 | 'Returns a shallow copy of a Source Collection 2340 | 'A new collection is created and then populated with values and references to 2341 | ' to the objects found in the original collection 2342 | 'Returns Nothing if the source is Nothing 2343 | '******************************************************************************* 2344 | Public Function ShallowCopyCollection(ByVal sourceColl As Collection) As Collection 2345 | If sourceColl Is Nothing Then Exit Function 2346 | ' 2347 | Dim v As Variant 2348 | Dim targetColl As New Collection 2349 | ' 2350 | For Each v In sourceColl 2351 | targetColl.Add v 2352 | Next v 2353 | Set ShallowCopyCollection = targetColl 2354 | End Function 2355 | 2356 | '******************************************************************************* 2357 | 'Returns a slice of a 1D array as a new 1D array 2358 | 'Parameters: 2359 | ' - arr: a 1D array to slice 2360 | ' - startIndex: the index of the first element to be added to result 2361 | ' - length_: the number of elements to return 2362 | ' - [outLowBound]: the start index of the result array. Default is 0 2363 | 'Notes: 2364 | ' - excess length is ignored 2365 | 'Raises error: 2366 | ' - 5 if: 2367 | ' * array is not 1-dimensional 2368 | ' * startIndex or length are invalid 2369 | 'Examples (assumed lower bound of array is 0): 2370 | ' - arr = [1,2,3,4], startIndex = 0 and length_ = 2 >> results [1,2] 2371 | ' - arr = [1,2,3,4], startIndex = 2 and length_ = 5 >> results [3,4] 2372 | '******************************************************************************* 2373 | Public Function Slice1DArray(ByRef arr As Variant _ 2374 | , ByVal startIndex As Long _ 2375 | , ByVal length_ As Long _ 2376 | , Optional ByVal outLowBound As Long = 0) As Variant 2377 | Const fullMethodName As String = MODULE_NAME & ".Slice1DArray" 2378 | ' 2379 | 'Check Input 2380 | If GetArrayDimsCount(arr) <> 1 Then 2381 | Err.Raise 5, fullMethodName, "Expected 1D Array" 2382 | ElseIf startIndex < LBound(arr, 1) Or startIndex > UBound(arr, 1) Then 2383 | Err.Raise 5, fullMethodName, "Invalid startIndex" 2384 | ElseIf length_ <= 0 Then 2385 | Err.Raise 5, fullMethodName, "Invalid slice length" 2386 | ElseIf startIndex = LBound(arr) _ 2387 | And startIndex + length_ > UBound(arr) _ 2388 | And startIndex = outLowBound _ 2389 | Then 2390 | Slice1DArray = arr 2391 | Exit Function 2392 | End If 2393 | ' 2394 | Dim endIndex As Long: endIndex = startIndex + length_ - 1 2395 | ' 2396 | 'Ignore excess length 2397 | If endIndex > UBound(arr, 1) Then endIndex = UBound(arr, 1) 2398 | ' 2399 | Dim res() As Variant 2400 | Dim i As Long 2401 | Dim adjust As Long: adjust = outLowBound - startIndex 2402 | ' 2403 | 'Add elements to result array 2404 | ReDim res(outLowBound To endIndex + adjust) 2405 | For i = startIndex To endIndex 2406 | If IsObject(arr(i)) Then 2407 | Set res(i + adjust) = arr(i) 2408 | Else 2409 | res(i + adjust) = arr(i) 2410 | End If 2411 | Next i 2412 | ' 2413 | Slice1DArray = res 2414 | End Function 2415 | 2416 | '******************************************************************************* 2417 | 'Returns a slice of a 2D array as a new 2D array 2418 | 'Parameters: 2419 | ' - arr: a 2D array to slice 2420 | ' - startRow: the index of the first row to be added to result 2421 | ' - startColumn: the index of the first column to be added to result 2422 | ' - height_: the number of rows to be returned 2423 | ' - width_: the number of columns to be returned 2424 | ' - [outLowRow]: the start index of the result's 1st dimension. Default is 0 2425 | ' - [outLowCol]: the start index of the result's 2nd dimension. Default is 0 2426 | 'Notes: 2427 | ' - excess height or width is ignored 2428 | 'Raises error: 2429 | ' - 5 if: 2430 | ' * array is not two-dimensional 2431 | ' * startRow, startColumn, height or width are invalid 2432 | 'Examples assuming arr = [1,2,3,4] with both lower bounds as 0: 2433 | ' [5,6,7,8] 2434 | ' - startRow = 0, startColumn = 1, height_ = 2, width_ = 2 >> results [2,3] 2435 | ' [6,7] 2436 | ' - startRow = 1, startColumn = 1, height_ = 2, width_ = 6 >> results [6,7,8] 2437 | '******************************************************************************* 2438 | Public Function Slice2DArray(ByRef arr As Variant _ 2439 | , ByVal startRow As Long _ 2440 | , ByVal startColumn As Long _ 2441 | , ByVal height_ As Long _ 2442 | , ByVal width_ As Long _ 2443 | , Optional ByVal outLowRow As Long = 0 _ 2444 | , Optional ByVal outLowCol As Long = 0) As Variant 2445 | Const fullMethodName As String = MODULE_NAME & ".Slice2DArray" 2446 | ' 2447 | 'Check Input 2448 | If GetArrayDimsCount(arr) <> 2 Then 2449 | Err.Raise 5, fullMethodName, "Array is not two-dimensional" 2450 | ElseIf startRow < LBound(arr, 1) Or startRow > UBound(arr, 1) Then 2451 | Err.Raise 5, fullMethodName, "Invalid startRow" 2452 | ElseIf startColumn < LBound(arr, 2) Or startColumn > UBound(arr, 2) Then 2453 | Err.Raise 5, fullMethodName, "Invalid startColumn" 2454 | ElseIf height_ <= 0 Then 2455 | Err.Raise 5, fullMethodName, "Invalid height" 2456 | ElseIf width_ <= 0 Then 2457 | Err.Raise 5, fullMethodName, "Invalid width" 2458 | ElseIf startRow = LBound(arr, 1) And startColumn = LBound(arr, 2) Then 2459 | If startRow + height_ > UBound(arr, 1) _ 2460 | And startColumn + width_ > UBound(arr, 2) Then 2461 | If startRow = outLowRow And startColumn = outLowCol Then 2462 | Slice2DArray = arr 2463 | Exit Function 2464 | End If 2465 | End If 2466 | End If 2467 | ' 2468 | Dim endRow As Long: endRow = startRow + height_ - 1 2469 | Dim endColumn As Long: endColumn = startColumn + width_ - 1 2470 | ' 2471 | 'Ignore excess lengths 2472 | If endRow > UBound(arr, 1) Then endRow = UBound(arr, 1) 2473 | If endColumn > UBound(arr, 2) Then endColumn = UBound(arr, 2) 2474 | ' 2475 | Dim res() As Variant 2476 | Dim i As Long 2477 | Dim j As Long 2478 | Dim adjustRow As Long: adjustRow = outLowRow - startRow 2479 | Dim adjustCol As Long: adjustCol = outLowCol - startColumn 2480 | ' 2481 | 'Add elements to result array 2482 | ReDim res(outLowRow To endRow + adjustRow _ 2483 | , outLowCol To endColumn + adjustCol) 2484 | For i = startRow To endRow 2485 | For j = startColumn To endColumn 2486 | If IsObject(arr(i, j)) Then 2487 | Set res(i + adjustRow, j + adjustCol) = arr(i, j) 2488 | Else 2489 | res(i + adjustRow, j + adjustCol) = arr(i, j) 2490 | End If 2491 | Next j 2492 | Next i 2493 | ' 2494 | Slice2DArray = res 2495 | End Function 2496 | 2497 | '******************************************************************************* 2498 | 'Returns a slice of a collection as a new collection 2499 | 'Parameters: 2500 | ' - coll: a collection to slice 2501 | ' - startIndex: the index of the first element to be added to result 2502 | ' - length_: the number of elements to return 2503 | 'Notes: 2504 | ' - excess length is ignored 2505 | 'Raises error: 2506 | ' - 91 if: 2507 | ' * Collection is not set 2508 | ' * startIndex or length are invalid 2509 | 'Examples: 2510 | ' - arr = [1,2,3,4], startIndex = 1 and length_ = 2 >> results [1,2] 2511 | ' - arr = [1,2,3,4], startIndex = 2 and length_ = 5 >> results [2,3,4] 2512 | '******************************************************************************* 2513 | Public Function SliceCollection(ByVal coll As Collection _ 2514 | , ByVal startIndex As Long _ 2515 | , ByVal length_ As Long) As Collection 2516 | Const fullMethodName As String = MODULE_NAME & ".SliceCollection" 2517 | ' 2518 | 'Check Input 2519 | If coll Is Nothing Then 2520 | Err.Raise 91, fullMethodName, "Collection not set" 2521 | ElseIf startIndex < 1 Or startIndex > coll.Count Then 2522 | Err.Raise 5, fullMethodName, "Invalid startIndex" 2523 | ElseIf length_ <= 0 Then 2524 | Err.Raise 5, fullMethodName, "Invalid slice length" 2525 | End If 2526 | ' 2527 | Dim endIndex As Long: endIndex = startIndex + length_ - 1 2528 | ' 2529 | 'Ignore excess length 2530 | If endIndex > coll.Count Then endIndex = coll.Count 2531 | ' 2532 | Dim collRes As New Collection 2533 | Dim i As Long 2534 | ' 2535 | 'Add elements to result collection 2536 | For i = startIndex To endIndex 2537 | collRes.Add coll.Item(i) 2538 | Next i 2539 | ' 2540 | Set SliceCollection = collRes 2541 | End Function 2542 | 2543 | '******************************************************************************* 2544 | 'Sort a 1D Array, in-place 2545 | 'Returns: 2546 | ' - the sorted 1D array 2547 | 'Parameters: 2548 | ' - arr: a 1D array of values to sort 2549 | ' - [sortAscending]: 2550 | ' * True - Ascending (default) 2551 | ' * False - Descending 2552 | ' - [useTextNumberAsNumber]: 2553 | ' * True - numbers stored as texts are considered numbers (default) 2554 | ' * False - numbers stored as texts are considered texts 2555 | ' - [caseSensitive]: 2556 | ' * True - compare texts as case-sensitive 2557 | ' * False - ignore case when comparing texts (default) 2558 | 'Notes: 2559 | ' - this function is using a Stable Quick Sort adaptation. See 'QuickSort' 2560 | ' method below 2561 | ' - the array is sorted in place so it is optional to use the return value of 2562 | ' the function 2563 | 'Raises Error: 2564 | ' - 5: if array is not one-dimensional 2565 | '******************************************************************************* 2566 | Public Function Sort1DArray(ByRef arr As Variant _ 2567 | , Optional ByVal sortAscending As Boolean = True _ 2568 | , Optional ByVal useTextNumberAsNumber As Boolean = True _ 2569 | , Optional ByVal caseSensitive As Boolean = False) As Variant 2570 | Const fullMethodName As String = MODULE_NAME & ".Sort1DArray" 2571 | ' 2572 | 'Check Input 2573 | If GetArrayDimsCount(arr) <> 1 Then 2574 | Err.Raise 5, fullMethodName, "Expected 1D Array" 2575 | ElseIf UBound(arr, 1) - LBound(arr, 1) <= 0 Then 2576 | Sort1DArray = arr '1 or no value / nothing to sort 2577 | Exit Function 2578 | End If 2579 | ' 2580 | Dim cOptions As COMPARE_OPTIONS 2581 | ' 2582 | 'Set Compare Options 2583 | cOptions.compAscending = sortAscending 2584 | cOptions.useTextNumberAsNumber = useTextNumberAsNumber 2585 | cOptions.compareMethod = IIf(caseSensitive, vbBinaryCompare, vbTextCompare) 2586 | ' 2587 | Dim lowerIndex As Long: lowerIndex = LBound(arr, 1) 2588 | Dim upperIndex As Long: upperIndex = UBound(arr, 1) 2589 | Dim arrIndex() As Long: ReDim arrIndex(lowerIndex To upperIndex) 2590 | Dim i As Long 2591 | ' 2592 | 'QuickSort is not a 'Stable' Sort. An array of indexes is needed to ensure 2593 | ' that equal values preserve their order. This is accomplished by sorting 2594 | ' the array of indexes at the same time with the actual array being sorted 2595 | ' and by comparing indexes when values are equal (or of equal rank) 2596 | For i = lowerIndex To upperIndex 2597 | arrIndex(i) = i 2598 | Next i 2599 | ' 2600 | QuickSortVector arr, lowerIndex, upperIndex, cOptions, arrIndex, vecArray 2601 | Sort1DArray = arr 'Useful for method chaining 2602 | End Function 2603 | 2604 | '******************************************************************************* 2605 | 'Sorts a Vector, in-place. Could be a 1D Array or a Collection 2606 | 'Notes: 2607 | ' - This method is recursive so the initial call must include the lower and 2608 | ' upper bounds of the 1D array 2609 | ' - The CompareValues function is used to compare elements 2610 | ' - To make this Sort a 'Stable' Sort, an array of indexes must be built and 2611 | ' passed in the initial call (from outside). This is done in order to ensure 2612 | ' that equal values preserve their order (by comparing initial indexes when 2613 | ' values are equal) 2614 | 'Theory: 2615 | ' - https://en.wikipedia.org/wiki/Quicksort 2616 | '******************************************************************************* 2617 | Private Sub QuickSortVector(ByRef vector As Variant _ 2618 | , ByVal lowIndex As Long _ 2619 | , ByVal uppIndex As Long _ 2620 | , ByRef cOptions As COMPARE_OPTIONS _ 2621 | , ByRef arrIndex() As Long _ 2622 | , ByVal vecType As VECTOR_TYPE) 2623 | If lowIndex >= uppIndex Then Exit Sub 2624 | ' 2625 | Dim p As Long: p = (lowIndex + uppIndex) \ 2 2626 | Dim piv As SORT_PIVOT: SetSortPivot piv, arrIndex(p), vector(p) 2627 | Dim newLoIndex As Long: newLoIndex = lowIndex 2628 | Dim newUpIndex As Long: newUpIndex = uppIndex 2629 | Dim cr As COMPARE_RESULT 2630 | ' 2631 | Do While newLoIndex <= newUpIndex 2632 | 'Increase 'newLoIndex' until a swap is needed 2633 | Do While newLoIndex < uppIndex 2634 | cr = CompareValues(vector(newLoIndex), piv.value_, cOptions) 2635 | If cr.mustSwap Then Exit Do 2636 | If cr.areEqual Then If arrIndex(newLoIndex) >= piv.index Then Exit Do 2637 | newLoIndex = newLoIndex + 1 2638 | Loop 2639 | 'Decrease 'newUpIndex' until a swap is needed 2640 | Do While newUpIndex > lowIndex 2641 | cr = CompareValues(piv.value_, vector(newUpIndex), cOptions) 2642 | If cr.mustSwap Then Exit Do 2643 | If cr.areEqual Then If piv.index >= arrIndex(newUpIndex) Then Exit Do 2644 | newUpIndex = newUpIndex - 1 2645 | Loop 2646 | 'Swap values, if needed 2647 | If newLoIndex <= newUpIndex Then 2648 | Select Case vecType 2649 | Case vecArray 2650 | Swap1DArrayValues vector, newLoIndex, newUpIndex 2651 | Case vecCollection 2652 | SwapCollectionValues vector, newLoIndex, newUpIndex 2653 | End Select 2654 | Swap1DArrayValues arrIndex, newLoIndex, newUpIndex 'Sync Indexes 2655 | newLoIndex = newLoIndex + 1 2656 | newUpIndex = newUpIndex - 1 2657 | End If 2658 | Loop 2659 | 'Sort both remaining sub-vectors 2660 | QuickSortVector vector, lowIndex, newUpIndex, cOptions, arrIndex, vecType 2661 | QuickSortVector vector, newLoIndex, uppIndex, cOptions, arrIndex, vecType 2662 | End Sub 2663 | 2664 | '******************************************************************************* 2665 | 'Set a SORT_PIVOT struct from values 2666 | '******************************************************************************* 2667 | Private Sub SetSortPivot(ByRef sPivot As SORT_PIVOT _ 2668 | , ByVal index As Long _ 2669 | , ByVal v As Variant) 2670 | sPivot.index = index 2671 | If IsObject(v) Then Set sPivot.value_ = v Else sPivot.value_ = v 2672 | End Sub 2673 | 2674 | '******************************************************************************* 2675 | 'Compare 2 values of unknown type (Variant) based on a ranking convention and 2676 | ' sorting compare options 2677 | 'Notes: 2678 | ' - GetDataTypeRank function (returns DATA_TYPE_RANK enumeration) is used to 2679 | ' rank the compared values based on a predefined enumeration. If the values 2680 | ' being compared are of different ranks then the comparison is made based 2681 | ' on rank alone 2682 | ' - Empty values are always moved at the end (ignoring sort order), mimicking 2683 | ' how Excel sorts ranges of values 2684 | ' - Note that we consider False < True (in VBA False > True), mimicking how 2685 | ' Excel sorts ranges of values 2686 | 'Utility for the QuickSort methods 2687 | '******************************************************************************* 2688 | Private Function CompareValues(ByRef val1 As Variant _ 2689 | , ByRef val2 As Variant _ 2690 | , ByRef cOptions As COMPARE_OPTIONS) As COMPARE_RESULT 2691 | Dim rnk1 As DATA_TYPE_RANK: rnk1 = GetDataTypeRank(val1) 2692 | Dim rnk2 As DATA_TYPE_RANK: rnk2 = GetDataTypeRank(val2) 2693 | ' 2694 | 'Adjust Rank for numbers stored as text, if needed 2695 | If cOptions.useTextNumberAsNumber Then 2696 | If rnk1 >= rankText And rnk2 >= rankText Then 2697 | If rnk1 = rankText Then If IsNumeric(val1) Then rnk1 = rankNumber 2698 | If rnk2 = rankText Then If IsNumeric(val2) Then rnk2 = rankNumber 2699 | End If 2700 | End If 2701 | ' 2702 | 'Compare ranks/values as appropriate 2703 | If rnk1 < rnk2 Then 2704 | CompareValues.mustSwap = (rnk1 = rankEmpty Or cOptions.compAscending) 2705 | ElseIf rnk1 > rnk2 Then 2706 | CompareValues.mustSwap = Not (rnk2 = rankEmpty Or cOptions.compAscending) 2707 | Else 'Ranks are equal 2708 | Select Case rnk1 2709 | Case rankEmpty, rankUDT, rankObject, rankArray, rankNull, rankError 2710 | CompareValues.areEqual = True 'For sorting purposes 2711 | Case rankBoolean 2712 | If val1 = val2 Then 2713 | CompareValues.areEqual = True 2714 | Else 2715 | 'Note that we consider False < True (in VBA False > True) 2716 | CompareValues.mustSwap = (cOptions.compAscending Xor val2) 2717 | End If 2718 | Case rankText 2719 | Select Case StrComp(val1, val2, cOptions.compareMethod) 2720 | Case -1: CompareValues.mustSwap = Not cOptions.compAscending 2721 | Case 0: CompareValues.areEqual = True 2722 | Case 1: CompareValues.mustSwap = cOptions.compAscending 2723 | End Select 2724 | Case rankNumber 2725 | Dim no1 As Double: no1 = CDbl(val1) 'Maybe test for decimal on Win 2726 | Dim no2 As Double: no2 = CDbl(val2) 2727 | ' 2728 | If no1 = no2 Then 2729 | CompareValues.areEqual = True 2730 | Else 2731 | CompareValues.mustSwap = (cOptions.compAscending Xor no1 < no2) 2732 | End If 2733 | End Select 2734 | End If 2735 | End Function 2736 | 2737 | '******************************************************************************* 2738 | 'Returns a rank (Enum) for a given value's data type which simplifies the number 2739 | ' of existing data types. This simplification speeds up the comparison of 2 2740 | ' values by removing the need to compare values of incompatible data types 2741 | '******************************************************************************* 2742 | Private Function GetDataTypeRank(ByRef varValue As Variant) As DATA_TYPE_RANK 2743 | If IsObject(varValue) Then 2744 | GetDataTypeRank = rankObject 2745 | Exit Function 2746 | End If 2747 | Select Case VarType(varValue) 2748 | Case vbNull 2749 | GetDataTypeRank = rankNull 2750 | Case vbEmpty 2751 | GetDataTypeRank = rankEmpty 2752 | Case vbError 2753 | GetDataTypeRank = rankError 2754 | Case vbBoolean 2755 | GetDataTypeRank = rankBoolean 2756 | Case vbString 2757 | GetDataTypeRank = rankText 2758 | Case vbByte, vbInteger, vbLong, vbLongLong 'Integers 2759 | GetDataTypeRank = rankNumber 2760 | Case vbCurrency, vbDecimal, vbDouble, vbSingle, vbDate 'Decimal-point 2761 | GetDataTypeRank = rankNumber 2762 | Case vbArray To vbArray + vbUserDefinedType 2763 | GetDataTypeRank = rankArray 2764 | Case vbUserDefinedType 2765 | GetDataTypeRank = rankUDT 2766 | Case vbDataObject 2767 | GetDataTypeRank = rankObject 2768 | End Select 2769 | End Function 2770 | 2771 | '******************************************************************************* 2772 | 'Sort a 2D Array by a particular column, in-place 2773 | 'Returns: 2774 | ' - the sorted 2D array using the specified column for comparison 2775 | 'Parameters: 2776 | ' - arr: a 2D array of values to sort 2777 | ' - sortColumn: the index of the column used for sorting 2778 | ' - [sortAscending]: 2779 | ' * True - Ascending (default) 2780 | ' * False - Descending 2781 | ' - [useTextNumberAsNumber]: 2782 | ' * True - numbers stored as texts are considered numbers (default) 2783 | ' * False - numbers stored as texts are considered texts 2784 | ' - [caseSensitive]: 2785 | ' * True - compare texts as case-sensitive 2786 | ' * False - ignore case when comparing texts (default) 2787 | 'Notes: 2788 | ' - this function is using a Stable Quick Sort adaptation. See 'QuickSort' 2789 | ' method below 2790 | ' - the array is sorted in place so it is optional to use the return value of 2791 | ' the function 2792 | 'Raises Error: 2793 | ' - 5 if: 2794 | ' * array is not two-dimensional 2795 | ' * sort column index is out of bounds 2796 | '******************************************************************************* 2797 | Public Function Sort2DArray(ByRef arr As Variant, ByVal sortColumn As Long _ 2798 | , Optional ByVal sortAscending As Boolean = True _ 2799 | , Optional ByVal useTextNumberAsNumber As Boolean = True _ 2800 | , Optional ByVal caseSensitive As Boolean = False) As Variant 2801 | Const fullMethodName As String = MODULE_NAME & ".Sort2DArray" 2802 | ' 2803 | 'Check Input 2804 | If GetArrayDimsCount(arr) <> 2 Then 2805 | Err.Raise 5, fullMethodName, "Array is not two-dimensional" 2806 | ElseIf sortColumn < LBound(arr, 2) Or sortColumn > UBound(arr, 2) Then 2807 | Err.Raise 5, fullMethodName, "Sort Column out of bounds" 2808 | ElseIf UBound(arr, 1) - LBound(arr, 1) = 0 Then 2809 | Sort2DArray = arr 'Only 1 row / nothing to sort 2810 | Exit Function 2811 | End If 2812 | ' 2813 | Dim cOptions As COMPARE_OPTIONS 2814 | ' 2815 | 'Set Compare Options 2816 | cOptions.compAscending = sortAscending 2817 | cOptions.useTextNumberAsNumber = useTextNumberAsNumber 2818 | cOptions.compareMethod = IIf(caseSensitive, vbBinaryCompare, vbTextCompare) 2819 | ' 2820 | Dim lowerRow As Long: lowerRow = LBound(arr, 1) 2821 | Dim upperRow As Long: upperRow = UBound(arr, 1) 2822 | Dim arrIndex() As Long: ReDim arrIndex(lowerRow To upperRow) 2823 | Dim i As Long 2824 | ' 2825 | 'QuickSort is not a 'Stable' Sort. An array of indexes is needed to ensure 2826 | ' that equal values preserve their order. This is accomplished by sorting 2827 | ' the array of indexes at the same time with the actual array being sorted 2828 | ' and by comparing indexes when values are equal (or of equal rank) 2829 | For i = lowerRow To upperRow 2830 | arrIndex(i) = i 2831 | Next i 2832 | ' 2833 | QuickSort2DArray arr, lowerRow, upperRow, sortColumn, cOptions, arrIndex 2834 | Sort2DArray = arr 'Useful for method chaining 2835 | End Function 2836 | 2837 | '******************************************************************************* 2838 | 'Sort a 2D Array (in place) by using a Stable Quick Sort adaptation. Stable 2839 | ' means that the order for equal elements is preserved 2840 | 'Notes: 2841 | ' - This method is recursive so the initial call must include the lower and 2842 | ' upper bounds of the first dimension 2843 | ' - The CompareValues function is used to compare elements on the sort column 2844 | ' - To make this Sort a 'Stable' Sort, an array of indexes must be built and 2845 | ' passed in the initial call (from outside). This is done in order to ensure 2846 | ' that equal values preserve their order (by comparing initial indexes when 2847 | ' values are equal) 2848 | 'Theory: 2849 | ' - https://en.wikipedia.org/wiki/Quicksort 2850 | '******************************************************************************* 2851 | Private Sub QuickSort2DArray(ByRef arr As Variant _ 2852 | , ByVal lowerRow As Long _ 2853 | , ByVal upperRow As Long _ 2854 | , ByVal sortColumn As Long _ 2855 | , ByRef cOptions As COMPARE_OPTIONS _ 2856 | , ByRef arrIndex() As Long) 2857 | If lowerRow >= upperRow Then Exit Sub 2858 | ' 2859 | Dim p As Long: p = (lowerRow + upperRow) \ 2 2860 | Dim piv As SORT_PIVOT: SetSortPivot piv, arrIndex(p), arr(p, sortColumn) 2861 | Dim newLowRow As Long: newLowRow = lowerRow 2862 | Dim newUppRow As Long: newUppRow = upperRow 2863 | Dim cr As COMPARE_RESULT 2864 | ' 2865 | Do While newLowRow <= newUppRow 2866 | 'Increase 'newLowRow' until a swap is needed 2867 | Do While newLowRow < upperRow 2868 | cr = CompareValues(arr(newLowRow, sortColumn), piv.value_, cOptions) 2869 | If cr.mustSwap Then Exit Do 2870 | If cr.areEqual Then If arrIndex(newLowRow) >= piv.index Then Exit Do 2871 | newLowRow = newLowRow + 1 2872 | Loop 2873 | 'Decrease 'newUppRow' until a swap is needed 2874 | Do While newUppRow > lowerRow 2875 | cr = CompareValues(piv.value_, arr(newUppRow, sortColumn), cOptions) 2876 | If cr.mustSwap Then Exit Do 2877 | If cr.areEqual Then If piv.index >= arrIndex(newUppRow) Then Exit Do 2878 | newUppRow = newUppRow - 1 2879 | Loop 2880 | 'Swap rows, if needed 2881 | If newLowRow <= newUppRow Then 2882 | Swap2DArrayRows arr, newLowRow, newUppRow 2883 | Swap1DArrayValues arrIndex, newLowRow, newUppRow 'Sync Indexes 2884 | newLowRow = newLowRow + 1 2885 | newUppRow = newUppRow - 1 2886 | End If 2887 | Loop 2888 | 'Sort both remaining sub-arrays 2889 | QuickSort2DArray arr, lowerRow, newUppRow, sortColumn, cOptions, arrIndex 2890 | QuickSort2DArray arr, newLowRow, upperRow, sortColumn, cOptions, arrIndex 2891 | End Sub 2892 | 2893 | '******************************************************************************* 2894 | 'Sorts a Collection, in-place 2895 | 'Returns: 2896 | ' - the sorted collection 2897 | 'Parameters: 2898 | ' - coll: a Collection to sort 2899 | ' - [sortAscending]: 2900 | ' * True - Ascending (default) 2901 | ' * False - Descending 2902 | ' - [useTextNumberAsNumber]: 2903 | ' * True - numbers stored as texts are considered numbers (default) 2904 | ' * False - numbers stored as texts are considered texts 2905 | ' - [caseSensitive]: 2906 | ' * True - compare texts as case-sensitive 2907 | ' * False - ignore case when comparing texts (default) 2908 | 'Notes: 2909 | ' - this function is using a Stable Quick Sort adaptation 2910 | ' - the collection is sorted in place so it is optional to use the return 2911 | ' value of the function 2912 | 'Raises Error: 2913 | ' - 91: if collection is not set 2914 | '******************************************************************************* 2915 | Public Function SortCollection(ByRef coll As Collection _ 2916 | , Optional ByVal sortAscending As Boolean = True _ 2917 | , Optional ByVal useTextNumberAsNumber As Boolean = True _ 2918 | , Optional ByVal caseSensitive As Boolean = False) As Collection 2919 | Const fullMethodName As String = MODULE_NAME & ".SortCollection" 2920 | ' 2921 | 'Check Input 2922 | If coll Is Nothing Then 2923 | Err.Raise 91, fullMethodName, "Collection not set" 2924 | ElseIf coll.Count <= 1 Then 2925 | Set SortCollection = coll '1 or no value / nothing to sort 2926 | Exit Function 2927 | End If 2928 | ' 2929 | Dim cOptions As COMPARE_OPTIONS 2930 | ' 2931 | 'Set Compare Options 2932 | cOptions.compAscending = sortAscending 2933 | cOptions.useTextNumberAsNumber = useTextNumberAsNumber 2934 | cOptions.compareMethod = IIf(caseSensitive, vbBinaryCompare, vbTextCompare) 2935 | ' 2936 | Dim arrIndex() As Long: ReDim arrIndex(1 To coll.Count) 2937 | Dim i As Long 2938 | ' 2939 | 'QuickSort is not a 'Stable' Sort. An array of indexes is needed to ensure 2940 | ' that equal values preserve their order. This is accomplished by sorting 2941 | ' the array of indexes at the same time with the actual array being sorted 2942 | ' and by comparing indexes when values are equal (or of equal rank) 2943 | For i = 1 To coll.Count 2944 | arrIndex(i) = i 2945 | Next i 2946 | ' 2947 | QuickSortVector coll, 1, coll.Count, cOptions, arrIndex, vecCollection 2948 | Set SortCollection = coll 'Useful for method chaining 2949 | End Function 2950 | 2951 | '******************************************************************************* 2952 | 'Swaps 2 values in a 1D Array, in-place 2953 | '******************************************************************************* 2954 | Private Sub Swap1DArrayValues(ByRef arr As Variant _ 2955 | , ByVal index1 As Long _ 2956 | , ByVal index2 As Long) 2957 | If index1 <> index2 Then SwapValues arr(index1), arr(index2) 2958 | End Sub 2959 | 2960 | '******************************************************************************* 2961 | 'Swaps 2 values in a Collection, in-place 2962 | '******************************************************************************* 2963 | Private Sub SwapCollectionValues(ByVal coll As Collection _ 2964 | , ByVal index1 As Long _ 2965 | , ByVal index2 As Long) 2966 | If index1 = index2 Then Exit Sub 2967 | ' 2968 | Dim i1 As Long 2969 | Dim i2 As Long 2970 | ' 2971 | If index1 < index2 Then 2972 | i1 = index1 2973 | i2 = index2 2974 | Else 2975 | i1 = index2 2976 | i2 = index1 2977 | End If 2978 | ' 2979 | coll.Add Item:=coll.Item(i1), Before:=i2 2980 | coll.Add Item:=coll.Item(i2 + 1), Before:=i1 2981 | coll.Remove i1 + 1 2982 | coll.Remove i2 + 1 2983 | End Sub 2984 | 2985 | '******************************************************************************* 2986 | 'Swaps 2 columns in a 2D Array, in-place 2987 | '******************************************************************************* 2988 | Private Sub Swap2DArrayColumns(ByRef arr As Variant _ 2989 | , ByVal column1 As Long _ 2990 | , ByVal column2 As Long) 2991 | If column1 <> column2 Then 2992 | Dim i As Long 2993 | ' 2994 | For i = LBound(arr, 1) To UBound(arr, 1) 2995 | SwapValues arr(i, column1), arr(i, column2) 2996 | Next i 2997 | End If 2998 | End Sub 2999 | 3000 | '******************************************************************************* 3001 | 'Swaps 2 rows in a 2D Array, in-place 3002 | '******************************************************************************* 3003 | Private Sub Swap2DArrayRows(ByRef arr As Variant _ 3004 | , ByVal row1 As Long _ 3005 | , ByVal row2 As Long) 3006 | If row1 <> row2 Then 3007 | Dim j As Long 3008 | ' 3009 | For j = LBound(arr, 2) To UBound(arr, 2) 3010 | SwapValues arr(row1, j), arr(row2, j) 3011 | Next j 3012 | End If 3013 | End Sub 3014 | 3015 | '******************************************************************************* 3016 | 'Swaps 2 values of any data type 3017 | '******************************************************************************* 3018 | Public Sub SwapValues(ByRef val1 As Variant, ByRef val2 As Variant) 3019 | Dim temp As Variant 3020 | Dim needsSet1 As Boolean: needsSet1 = IsObject(val1) 3021 | Dim needsSet2 As Boolean: needsSet2 = IsObject(val2) 3022 | ' 3023 | If needsSet1 Then Set temp = val1 Else temp = val1 3024 | If needsSet2 Then Set val1 = val2 Else val1 = val2 3025 | If needsSet1 Then Set val2 = temp Else val2 = temp 3026 | End Sub 3027 | 3028 | '******************************************************************************* 3029 | 'Returns a Collection where keys are the received list of texts and items 3030 | ' are their corresponding position/index 3031 | 'Parameters: 3032 | ' - arrText: a 1D array or a 2D array with 1 column or 1 row of values that 3033 | ' are or can be casted to String 3034 | ' - [ignoreDuplicates]: 3035 | ' * True - any duplicated text is ignored (first found position returned) 3036 | ' * False - error 457 will get raised if duplicate is found 3037 | 'Raises error: 3038 | ' - 457: if duplicate is found and 'ignoreDuplicates' is set to 'False' 3039 | ' - 13: if any of the values received cannot be casted to String 3040 | ' - 5: if input is not a 1D array or a single row/column 2D array 3041 | 'Example usage: 3042 | ' Dim arrHeaders() As Variant: arrHeaders = headersRange.Value2 3043 | ' Dim headerIndex As Collection: Set headerIndex = TextArrayToIndex(arrHeaders) 3044 | ' Dim v As Variant 3045 | ' Dim h As String 3046 | ' For Each v In requiredHeadersList 3047 | ' If Not CollectionHasKey(headerIndex, v) Then 3048 | ' MsgBox "Missing header: " & v 3049 | ' Exit Sub 3050 | ' End If 3051 | ' Next v 3052 | ' h = "An existing header" 3053 | ' Debug.Print "Position of " & h & " is " & headerIndex(h) 3054 | '******************************************************************************* 3055 | Public Function TextArrayToIndex(ByRef arrText() As Variant _ 3056 | , Optional ByVal ignoreDuplicates As Boolean = True) As Collection 3057 | Const fullMethodName As String = MODULE_NAME & ".TextArrayToIndex" 3058 | ' 3059 | Dim i As Long 3060 | Dim v As Variant 3061 | Dim collIndex As New Collection 3062 | Dim dimsCount As Long: dimsCount = GetArrayDimsCount(arrText) 3063 | Const errDuplicate As Long = 457 3064 | ' 3065 | If dimsCount = 2 Then 3066 | Dim r As Long: r = UBound(arrText, 1) - LBound(arrText, 1) + 1 3067 | Dim c As Long: c = UBound(arrText, 2) - LBound(arrText, 2) + 1 3068 | ' 3069 | If r > 1 And c > 1 Then 3070 | Err.Raise 5, fullMethodName, "Expected row or column of texts" 3071 | ElseIf r = 1 Then 3072 | i = LBound(arrText, 2) 3073 | Else 3074 | i = LBound(arrText, 1) 3075 | End If 3076 | ElseIf dimsCount = 1 Then 3077 | i = LBound(arrText, 1) 3078 | Else 3079 | Err.Raise 5, fullMethodName, "Expected 1D or 2D array of text values" 3080 | End If 3081 | ' 3082 | On Error Resume Next 3083 | For Each v In arrText 3084 | collIndex.Add i, CStr(v) 3085 | If Err.Number <> 0 Then 3086 | If Err.Number = errDuplicate Then 3087 | If Not ignoreDuplicates Then 3088 | On Error GoTo 0 3089 | Err.Raise errDuplicate, fullMethodName, "Duplicated text" 3090 | End If 3091 | Else 3092 | On Error GoTo 0 3093 | Err.Raise 13, fullMethodName, "Type mismatch. Expected text" 3094 | End If 3095 | End If 3096 | i = i + 1 3097 | Next v 3098 | On Error GoTo 0 3099 | ' 3100 | Set TextArrayToIndex = collIndex 3101 | End Function 3102 | 3103 | '******************************************************************************* 3104 | 'Transposes a 1D or 2D Array 3105 | 'Raises error: 3106 | ' - 5: if input array is not 1D or 2D 3107 | 'Notes: 3108 | ' - 1D Arrays are transposed to a 1 column 2D Array 3109 | ' - resulting bounds are reflecting the input bounds 3110 | '******************************************************************************* 3111 | Public Function TransposeArray(ByRef arr As Variant) As Variant() 3112 | Const fullMethodName As String = MODULE_NAME & ".TransposeArray" 3113 | Dim res() As Variant 3114 | ' 3115 | Select Case GetArrayDimsCount(arr) 3116 | Case 1 3117 | If LBound(arr, 1) > UBound(arr, 1) Then 3118 | TransposeArray = ZeroLengthArray() 3119 | Exit Function 3120 | End If 3121 | Dim lowBound As Long: lowBound = LBound(arr, 1) 3122 | ReDim res(lowBound To UBound(arr, 1), lowBound To lowBound) 3123 | Case 2 3124 | ReDim res(LBound(arr, 2) To UBound(arr, 2) _ 3125 | , LBound(arr, 1) To UBound(arr, 1)) 3126 | Case Else 3127 | Err.Raise 5, fullMethodName, "Expected 1D or 2D Array" 3128 | End Select 3129 | ' 3130 | Dim v As Variant 3131 | Dim lowerCol As Long: lowerCol = LBound(res, 2) 3132 | Dim upperCol As Long: upperCol = UBound(res, 2) 3133 | Dim i As Long: i = LBound(res, 1) 3134 | Dim j As Long: j = lowerCol 3135 | ' 3136 | 'For Each... loop is faster than using 2 For... Next loops 3137 | For Each v In arr 'Column-major order 3138 | If IsObject(v) Then Set res(i, j) = v Else res(i, j) = v 3139 | If j = upperCol Then 'Switch to next row 3140 | i = i + 1 3141 | j = lowerCol 3142 | Else 3143 | j = j + 1 3144 | End If 3145 | Next v 3146 | TransposeArray = res 3147 | End Function 3148 | 3149 | '******************************************************************************* 3150 | 'Receives a value or multiple values via a variant and returns either a single 3151 | ' collection containing all the values (from all nest levels) or nested 3152 | ' collections 3153 | 'Parameters: 3154 | ' - values: the Value(s) that will be returned in a new collection 3155 | ' - nestType (applicable to array/collection/range but can be extended): 3156 | ' * nestNone - return a single collection of values that are not nested. 3157 | ' No returned element can be an array, Excel Range or a collection 3158 | ' * nestMultiItemsOnly - maintain original nesting but only if the list 3159 | ' (array/collection/range) has more than 1 element and return 3160 | ' collection(s) inside collection(s). Arrays and Ranges are turned into 3161 | ' Collections as well 3162 | ' * nestAll - maintain original nesting and return collection(s) inside 3163 | ' collection(s). Arrays and Ranges are turned into Collections as well 3164 | ' - traverseArrType (applicable to multi-dimensional arrays only): 3165 | ' * rowWise 3166 | ' * columnWise 3167 | 'Does not raise errors 3168 | 'Notes: 3169 | ' - invalid array traverseType values are defaulted to column-wise order 3170 | ' - invalid nestType values are defaulted to nestNone (no nesting) 3171 | ' - uninitialized arrays are ignored 3172 | '******************************************************************************* 3173 | Public Function ValuesToCollection(ByRef values As Variant _ 3174 | , ByVal nestType As NESTING_TYPE _ 3175 | , ByVal traverseArrType As ARRAY_TRAVERSE_TYPE) As Collection 3176 | If traverseArrType <> rowWise Then traverseArrType = columnWise 3177 | If nestType < [_nMin] And nestType > [_nMax] Then nestType = nestNone 3178 | ' 3179 | Dim coll As New Collection 3180 | ' 3181 | AddToCollection values, coll, nestType, traverseArrType, False, True 3182 | Set ValuesToCollection = coll 3183 | End Function 3184 | 3185 | '******************************************************************************* 3186 | 'Adds all values to the specified target collection, recursively 3187 | 'Called from ValuesToCollection 3188 | '******************************************************************************* 3189 | Private Sub AddToCollection(ByRef values As Variant _ 3190 | , ByVal coll As Collection _ 3191 | , ByVal nestType As NESTING_TYPE _ 3192 | , ByVal traverseType As ARRAY_TRAVERSE_TYPE _ 3193 | , ByVal hasSiblings As Boolean _ 3194 | , Optional ByVal isRoot As Boolean = False) 3195 | Dim v As Variant 3196 | Dim hasMultiItems As Boolean 3197 | ' 3198 | If IsObject(values) Then 3199 | If values Is Nothing Then 3200 | coll.Add Nothing 3201 | ElseIf TypeOf values Is Collection Then 3202 | hasMultiItems = (values.Count > 1) 3203 | If NeedsNesting(nestType, hasMultiItems, hasSiblings, isRoot) Then 3204 | Set coll = AddNewCollectionTo(coll) 3205 | End If 3206 | For Each v In values 3207 | AddToCollection v, coll, nestType, traverseType, hasMultiItems 3208 | Next v 3209 | ElseIf IsExcelRange(values) Then 3210 | hasMultiItems = (values.Count > 1) 3211 | If NeedsNesting(nestType, hasMultiItems, hasSiblings, isRoot) Then 3212 | Set coll = AddNewCollectionTo(coll) 3213 | End If 3214 | For Each v In values.Areas 3215 | AddToCollection v.Value2, coll, nestNone, traverseType, hasMultiItems 3216 | Next v 3217 | Else 3218 | 'Logic can be added here, for any other object type(s) needed 3219 | coll.Add values 3220 | End If 3221 | ElseIf IsArray(values) Then 3222 | Dim dimsCount As Long: dimsCount = GetArrayDimsCount(values) 3223 | ' 3224 | If dimsCount > 0 Then 3225 | hasMultiItems = (GetArrayElemCount(values) > 1) 3226 | If NeedsNesting(nestType, hasMultiItems, hasSiblings, isRoot) Then 3227 | Set coll = AddNewCollectionTo(coll) 3228 | End If 3229 | If traverseType = rowWise And dimsCount > 1 Then 3230 | values = NDArrayTo1DArray(values, rowWise) 3231 | End If 3232 | For Each v In values 3233 | AddToCollection v, coll, nestType, traverseType, hasMultiItems 3234 | Next v 3235 | End If 3236 | Else 3237 | coll.Add values 3238 | End If 3239 | End Sub 3240 | 3241 | '******************************************************************************* 3242 | 'Utility for 'AddToCollection' 3243 | '******************************************************************************* 3244 | Private Function NeedsNesting(ByVal nestType As NESTING_TYPE _ 3245 | , ByVal hasMultiItems As Boolean _ 3246 | , ByVal hasSiblings As Boolean _ 3247 | , ByVal isRoot As Boolean) As Boolean 3248 | Select Case nestType 3249 | Case nestAll: NeedsNesting = Not isRoot 3250 | Case nestMultiItemsOnly: NeedsNesting = (hasMultiItems And hasSiblings) 3251 | Case Else: NeedsNesting = False 3252 | End Select 3253 | End Function 3254 | 3255 | '******************************************************************************* 3256 | 'Utility for 'AddToCollection' 3257 | '******************************************************************************* 3258 | Private Function AddNewCollectionTo(ByVal collTarget As Collection) As Collection 3259 | Set AddNewCollectionTo = New Collection 3260 | collTarget.Add AddNewCollectionTo 3261 | End Function 3262 | 3263 | '******************************************************************************* 3264 | 'Checks if a Variant is of Excel.Range type 3265 | 'It compiles for other Applications in addition to Excel (like Word, PowerPoint) 3266 | '******************************************************************************* 3267 | Private Function IsExcelRange(ByRef v As Variant) As Boolean 3268 | If TypeName(v) = "Range" Then 3269 | On Error Resume Next 3270 | IsExcelRange = (v.Areas.Count > 0) 3271 | On Error GoTo 0 3272 | End If 3273 | End Function 3274 | 3275 | '******************************************************************************* 3276 | 'Returns a Zero-Length array of Variant type 3277 | '******************************************************************************* 3278 | Public Function ZeroLengthArray() As Variant() 3279 | #If Mac Then 3280 | ZeroLengthArray = Array() 3281 | #Else 3282 | #If Win64 Then 3283 | ZeroLengthArray = Array() 'Could be done using APIs as below 3284 | #Else 3285 | 'There's a bug in x32 when using Array(). It cannot be assigned to 3286 | ' another Variant, cannot be added to Collections/Arrays 3287 | 'Solution is to build an array using Windows APIs 3288 | ' 3289 | 'Update Jan-2021 3290 | 'The bug seems to have been fixed in newer version of Excel so, a 3291 | ' static array will be used to mimimize Win API calls 3292 | Static zArr As Variant 3293 | Static isArrSet As Boolean 3294 | ' 3295 | If Not isArrSet Then 3296 | zArr = Array() 3297 | ' 3298 | 'Try assigning to another variant 3299 | Dim v As Variant 3300 | On Error Resume Next 3301 | v = zArr 3302 | isArrSet = (Err.Number = 0) 3303 | On Error GoTo 0 3304 | End If 3305 | If Not isArrSet Then 3306 | Const vType As Integer = vbVariant 3307 | Dim bounds(0 To 0) As SAFEARRAYBOUND 3308 | Dim ptrArray As Long 'No need for LongPtr (x32 branch) 3309 | Dim tVariant As TagVariant 3310 | ' 3311 | 'Create empty array and store pointer 3312 | ptrArray = SafeArrayCreate(vType, 1, bounds(0)) 3313 | ' 3314 | 'Create a Variant pointing to the array 3315 | tVariant.vt = vbArray + vType 3316 | tVariant.ptr = ptrArray 3317 | ' 3318 | 'Copy result 3319 | VariantCopy zArr, tVariant 3320 | ' 3321 | 'Clean-up 3322 | SafeArrayDestroy ptrArray 3323 | isArrSet = True 3324 | End If 3325 | ZeroLengthArray = zArr 3326 | #End If 3327 | #End If 3328 | End Function 3329 | -------------------------------------------------------------------------------- /src/Test/frmTestResults.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmTestResults 3 | Caption = "Test" 4 | ClientHeight = 6585 5 | ClientLeft = 120 6 | ClientTop = 465 7 | ClientWidth = 12390 8 | OleObjectBlob = "frmTestResults.frx":0000 9 | StartUpPosition = 1 'CenterOwner 10 | End 11 | Attribute VB_Name = "frmTestResults" 12 | Attribute VB_GlobalNameSpace = False 13 | Attribute VB_Creatable = False 14 | Attribute VB_PredeclaredId = True 15 | Attribute VB_Exposed = False 16 | '''============================================================================= 17 | ''' VBA ArrayTools 18 | '''----------------------------------------------- 19 | ''' https://github.com/cristianbuse/VBA-ArrayTools 20 | '''----------------------------------------------- 21 | ''' 22 | ''' Copyright (c) 2012 Ion Cristian Buse 23 | ''' 24 | ''' Permission is hereby granted, free of charge, to any person obtaining a copy 25 | ''' of this software and associated documentation files (the "Software"), to deal 26 | ''' in the Software without restriction, including without limitation the rights 27 | ''' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 28 | ''' copies of the Software, and to permit persons to whom the Software is 29 | ''' furnished to do so, subject to the following conditions: 30 | ''' 31 | ''' The above copyright notice and this permission notice shall be included in all 32 | ''' copies or substantial portions of the Software. 33 | ''' 34 | ''' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 35 | ''' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 36 | ''' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 37 | ''' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 38 | ''' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 39 | ''' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 40 | ''' SOFTWARE. 41 | '''============================================================================= 42 | 43 | Option Explicit 44 | 45 | Private m_codeModuleName As String 46 | 47 | Private Sub UserForm_Initialize() 48 | If Application.Left + Application.Width > 0 Then 49 | Me.StartUpPosition = 0 50 | Me.Left = Application.Left + Application.Width / 2 - Me.Width / 2 51 | Me.Top = Application.Top + Application.Height / 2 - Me.Height / 2 52 | End If 53 | End Sub 54 | 55 | Public Sub SetSummary(ByVal failedCount As Long, ByVal totalCount As Long, ByVal secondsDuration As Double) 56 | lblPassed.Visible = (failedCount = 0) 57 | lblFailed.Visible = Not lblPassed.Visible 58 | ' 59 | lblSummary.Caption = failedCount & " failed out of " & totalCount _ 60 | & " (" & Format$(secondsDuration, "0.000") & " seconds)" 61 | End Sub 62 | 63 | Public Property Let TestList(ByRef arr() As String) 64 | On Error Resume Next 65 | lboxTests.List = arr 66 | On Error GoTo 0 67 | End Property 68 | 69 | Public Property Let CodeModuleName(ByVal newVal As String) 70 | m_codeModuleName = newVal 71 | End Property 72 | 73 | Private Sub btnCancel_Click() 74 | Me.Hide 75 | End Sub 76 | 77 | Private Sub lboxTests_Change() 78 | Dim hasSelection As Boolean 79 | ' 80 | hasSelection = (lboxTests.ListIndex > -1) 81 | btnJump.Enabled = hasSelection 82 | If Not hasSelection Then Exit Sub 83 | ' 84 | tboxSelected.Text = lboxTests.List(lboxTests.ListIndex, 2) 85 | End Sub 86 | 87 | '******************************************************************************* 88 | 'Jumpes to the code of the selected method 89 | '******************************************************************************* 90 | Private Sub lboxTests_DblClick(ByVal Cancel As MSForms.ReturnBoolean) 91 | If lboxTests.ListIndex = -1 Then Exit Sub 92 | JumpToMethod lboxTests.List(lboxTests.ListIndex, 0) 93 | End Sub 94 | 95 | '******************************************************************************* 96 | 'Jumpes to the code of the selected method 97 | '******************************************************************************* 98 | Private Sub btnJump_Click() 99 | If lboxTests.ListIndex = -1 Then Exit Sub 100 | JumpToMethod lboxTests.List(lboxTests.ListIndex, 0) 101 | End Sub 102 | 103 | '******************************************************************************* 104 | 'Jumps to the selected method in the code pane 105 | '******************************************************************************* 106 | Private Sub JumpToMethod(ByVal methodName As String) 107 | If Not IsAccessToVBProjectsOn() Then 108 | MsgBox "You do not have access to VBProject" & vbNewLine & vbNewLine _ 109 | & "To turn access on, go to:" & vbNewLine & "File/Options/Trust " _ 110 | & "Center/Trust Center Settings/Macro Settings/Developer Macro " _ 111 | & "Settings and check ""Trust access to the VBA project object " _ 112 | & "model"" checkbox!", vbExclamation, "Missing VB Projects Access" 113 | Exit Sub 114 | End If 115 | ' 116 | Dim codeModule_ As Object 117 | Set codeModule_ = ThisWorkbook.VBProject.VBComponents(m_codeModuleName).CodeModule 118 | Dim endRow As Long 119 | Dim endCol As Long 120 | ' 121 | If codeModule_.Find(methodName & "(", 1, 1, endRow, endCol) Then 122 | Me.Hide 123 | codeModule_.CodePane.Show 124 | codeModule_.CodePane.SetSelection endRow, 1, endRow, endCol 125 | Else 126 | MsgBox "Method not found", vbExclamation, "Not found" 127 | End If 128 | End Sub 129 | 130 | '******************************************************************************* 131 | 'Checks if "Trust access to the VBA project object model" is on 132 | '******************************************************************************* 133 | Private Function IsAccessToVBProjectsOn() As Boolean 134 | Dim dummyProject As Object 135 | ' 136 | On Error Resume Next 137 | Set dummyProject = ThisWorkbook.VBProject 138 | IsAccessToVBProjectsOn = (Err.Number = 0) 139 | On Error GoTo 0 140 | End Function 141 | -------------------------------------------------------------------------------- /src/Test/frmTestResults.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cristianbuse/VBA-ArrayTools/146b016961c32ad0e301349edd23e7df43243b98/src/Test/frmTestResults.frx -------------------------------------------------------------------------------- /src/UDF_DataManipulation.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "UDF_DataManipulation" 2 | '''============================================================================= 3 | ''' VBA ArrayTools 4 | '''----------------------------------------------- 5 | ''' https://github.com/cristianbuse/VBA-ArrayTools 6 | '''----------------------------------------------- 7 | ''' 8 | ''' Copyright (c) 2012 Ion Cristian Buse 9 | ''' 10 | ''' Permission is hereby granted, free of charge, to any person obtaining a copy 11 | ''' of this software and associated documentation files (the "Software"), to deal 12 | ''' in the Software without restriction, including without limitation the rights 13 | ''' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 14 | ''' copies of the Software, and to permit persons to whom the Software is 15 | ''' furnished to do so, subject to the following conditions: 16 | ''' 17 | ''' The above copyright notice and this permission notice shall be included in all 18 | ''' copies or substantial portions of the Software. 19 | ''' 20 | ''' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 21 | ''' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 22 | ''' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 23 | ''' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 24 | ''' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 25 | ''' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 26 | ''' SOFTWARE. 27 | '''============================================================================= 28 | 29 | Option Explicit 30 | 31 | '******************************************************************************* 32 | ''Excel Data Manipulation Module 33 | ''Functions in this module are dynamic array formulas that allow easy data 34 | '' manipulation within the Excel interface using the ArrayTools library 35 | ''In newer versions of Excel some of the functions presented below are native to 36 | '' Excel (FILTER, SORT, SEQUENCE, UNIQUE and others) but the functionality is 37 | '' slightly different. It was announced in fall 2018 for Office 365 users 38 | '' For example: 39 | '' - DM_FILTER allows filtering on the returned result of another function 40 | '' - DM_SORT function allows case sensitive texts and more 41 | '' - DM_UNIQUE function allows to choose the columns used for uniquifying 42 | '' The functions below are capable to 'spill' on newer Excel versions 43 | '******************************************************************************* 44 | 45 | ''Important! 46 | '******************************************************************************* 47 | ''This module is intended to be used in Microsoft Excel only! 48 | ''Call the User-Defined-Functions (UDFs) in this module from Excel Ranges only 49 | '' DO NOT call these functions from VBA! If you need any of the functions below 50 | '' directly in VBA then use their equivalent from the LibArrayTools module 51 | '******************************************************************************* 52 | 53 | ''Requires: 54 | '' - LibArrayTools: library module with Array/Collection tools 55 | 56 | ''Exposed Excel UDFs: 57 | '' - DM_ARRAY 58 | '' - DM_FILTER 59 | '' - DM_INSERT 60 | '' - DM_INSERT2 61 | '' - DM_MERGE 62 | '' - DM_REVERSE 63 | '' - DM_SEQUENCE 64 | '' - DM_SLICE 65 | '' - DM_SORT 66 | '' - DM_UNIQUE 67 | 68 | '******************************************************************************* 69 | 'Turn the below compiler constant to True if you are using the LibUDFs library 70 | 'https://github.com/cristianbuse/VBA-FastExcelUDFs 71 | #Const USE_LIB_FAST_UDFS = False 72 | '******************************************************************************* 73 | 74 | '############################################################################### 75 | 'Register/Unregister Function Help for the Excel Function Arguments Dialog 76 | 'Notes: 77 | ' - a dummy parameter is used to hide the methods from the Excel Macro Dialog 78 | ' - ArgumentDescriptions not available for older versions of Excel e.g. 2007 79 | '############################################################################### 80 | Public Sub RegisterDMFunctions(Optional ByVal dummy As Boolean) 81 | RegisterDMArray 82 | RegisterDMFilter 83 | RegisterDMInsert 84 | RegisterDMInsert2 85 | RegisterDMMerge 86 | RegisterDMReverse 87 | RegisterDMSequence 88 | RegisterDMSlice 89 | RegisterDMSort 90 | RegisterDMUnique 91 | End Sub 92 | Public Sub UnregisterDMFunctions(Optional ByVal dummy As Boolean) 93 | UnregisterDMArray 94 | UnregisterDMFilter 95 | UnRegisterDMInsert 96 | UnRegisterDMInsert2 97 | UnregisterDMMerge 98 | UnregisterDMReverse 99 | UnregisterDMSequence 100 | UnregisterDMSlice 101 | UnregisterDMSort 102 | UnregisterDMUnique 103 | End Sub 104 | 105 | '******************************************************************************* 106 | 'Returns specified value(s) in a 1D or 2D array format 107 | 'Parameters: 108 | ' - columnsCount: the number of columns the output 2D array will have 109 | ' if 0 then a 1D array will be returned 110 | ' - values: the value(s) to be returned 111 | 'Notes: 112 | ' - uses LibArrayTools functions: 113 | ' * CollectionTo1DArray 114 | ' * CollectionTo2Darray 115 | ' * ReplaceEmptyInArray 116 | ' * ValuesToCollection 117 | ' - can be used to easily 'JOIN' ranges/arrays of values 118 | '******************************************************************************* 119 | Public Function DM_ARRAY(ByVal columnsCount As Long _ 120 | , ParamArray values() As Variant _ 121 | ) As Variant 122 | Application.Volatile False 123 | #If USE_LIB_FAST_UDFS Then 124 | LibUDFs.TriggerFastUDFCalculation 125 | #End If 126 | ' 127 | If columnsCount < 0 Then GoTo FailInput 128 | ' 129 | 'Get values to Collection 130 | Dim v As Variant: v = values 131 | Dim coll As Collection 132 | Set coll = LibArrayTools.ValuesToCollection(v, nestNone, rowWise) 133 | ' 134 | 'Return 1D or 2D array 135 | If columnsCount = 0 Then 136 | DM_ARRAY = LibArrayTools.CollectionTo1DArray(coll) 137 | Else 138 | 'If the number of elements in the collection is not divisible by the 139 | ' columns count then add #N/A to fill the last row 140 | Dim remainders As Long: remainders = coll.Count Mod columnsCount 141 | ' 142 | If remainders > 0 Then 143 | Dim errNA As Variant: errNA = VBA.CVErr(xlErrNA) 144 | Dim i As Long 145 | ' 146 | For i = 1 To columnsCount - remainders 147 | coll.Add errNA 148 | Next i 149 | End If 150 | DM_ARRAY = LibArrayTools.CollectionTo2DArray(coll, columnsCount) 151 | End If 152 | ' 153 | 'Replace the special value Empty with empty String so it is not returned 154 | ' as 0 (zero) in the caller Range 155 | LibArrayTools.ReplaceEmptyInArray DM_ARRAY, vbNullString 156 | Exit Function 157 | FailInput: 158 | DM_ARRAY = VBA.CVErr(xlErrValue) 159 | End Function 160 | 161 | '############################################################################### 162 | 'Help for the Function Arguments Dialog in Excel - DM_ARRAY 163 | '############################################################################### 164 | Private Sub RegisterDMArray() 165 | Dim arg1 As String 166 | Dim arg2 As String 167 | ' 168 | arg1 = "the number of columns the output 2D array will have" & vbNewLine _ 169 | & "Use 0 (zero) to return a 1D Array" 170 | arg2 = "any value (Range, Named Range, Array, number, text etc.)" 171 | ' 172 | Application.MacroOptions Macro:="DM_ARRAY" _ 173 | , Description:="Returns specified value(s) in a joined 1D or 2D array" _ 174 | , ArgumentDescriptions:=Array(arg1, arg2) 175 | End Sub 176 | Private Sub UnregisterDMArray() 177 | Application.MacroOptions Macro:="DM_ARRAY", Description:=Empty _ 178 | , ArgumentDescriptions:=Array(Empty, Empty) 179 | End Sub 180 | 181 | '******************************************************************************* 182 | 'Filters a 2D array (or a 1-Area Range) vertically by the specified column index 183 | 'Returns: 184 | ' - the filtered array or an Excel #VALUE! or #CALC! error 185 | 'Parameters: 186 | ' - columnIndex: the index of the column to be used for filtering 187 | ' - arr: the 2D array that needs filtering 188 | ' - filters: pairs of Operator and Comparison Value to be used for filtering 189 | ' Ex. {">=", 3, "=<", 17, "NOT IN", MyRange} would return numbers from 'arr' 190 | ' between 3 and 17 that are not in the values of MyRange 191 | 'Notes: 192 | ' - uses LibArrayTools functions: 193 | ' * CreateFiltersArray 194 | ' * Filter2DArray 195 | ' * GetArrayElemCount 196 | ' * OneDArrayTo2DArray 197 | ' * ReplaceEmptyInArray 198 | ' - single values are converted to 1-element 1D array 199 | ' - 1D arrays are converted to 1-row 2D arrays 200 | ' - accepted operators (as Strings - see 'GetCondOperatorFromText' method) 201 | ' * comparison operators: =, <, >, <=, >=, <> 202 | ' * inclusion operators: IN , NOT IN 203 | ' accepts a list (array/range) as the comparison value 204 | ' * pattern matching operators: LIKE, NOT LIKE 205 | ' accepts pattern as the comparison value. For available patterns check 206 | ' the help for the VBA LIKE operator 207 | '******************************************************************************* 208 | Public Function DM_FILTER(ByVal columnIndex As Long, ByRef arr As Variant _ 209 | , ParamArray filters() As Variant _ 210 | ) As Variant 211 | Attribute DM_FILTER.VB_Description = "Filters a 2D array/range by the specified column index" 212 | Attribute DM_FILTER.VB_ProcData.VB_Invoke_Func = " \n14" 213 | Application.Volatile False 214 | #If USE_LIB_FAST_UDFS Then 215 | LibUDFs.TriggerFastUDFCalculation 216 | #End If 217 | ' 218 | 'Only accept 1-Area Ranges. This could alternatively be changed to ignore 219 | ' the extra Areas by arr = arr.Areas(1).Value2 instead of the 2 lines 220 | If VBA.TypeName(arr) = "Range" Then 221 | If arr.Areas.Count > 1 Then GoTo FailInput 222 | arr = arr.Value2 223 | End If 224 | ' 225 | 'Convert single value to 1-element 1D array 226 | If Not VBA.IsArray(arr) Then arr = Array(arr) 227 | ' 228 | Select Case LibArrayTools.GetArrayDimsCount(arr) 229 | Case 2 230 | 'Continue 231 | Case 1 'Convert to 1-row 2D array and adjust column index 232 | Dim colsCount As Long: colsCount = UBound(arr) - LBound(arr) + 1 233 | arr = LibArrayTools.OneDArrayTo2DArray(arr, colsCount) 234 | columnIndex = columnIndex + LBound(arr, 2) - 1 235 | Case Else 236 | GoTo FailInput 'Should not happen if called from Excel 237 | End Select 238 | ' 239 | On Error GoTo ErrorHandler 240 | DM_FILTER = LibArrayTools.Filter2DArray(arr, columnIndex _ 241 | , LibArrayTools.CreateFiltersArray(filters)) 242 | ' 243 | If LibArrayTools.GetArrayElemCount(DM_FILTER) = 0 Then 244 | DM_FILTER = VBA.CVErr(xlErrCalc) 245 | Else 246 | 'Replace the special value Empty with empty String so it is not 247 | ' returned as 0 (zero) in the caller Range 248 | LibArrayTools.ReplaceEmptyInArray DM_FILTER, vbNullString 249 | End If 250 | Exit Function 251 | ErrorHandler: 252 | FailInput: 253 | DM_FILTER = VBA.CVErr(xlErrValue) 254 | End Function 255 | 256 | '############################################################################### 257 | 'Help for the Function Arguments Dialog in Excel - DM_FILTER 258 | '############################################################################### 259 | Private Sub RegisterDMFilter() 260 | Dim arg1 As String 261 | Dim arg2 As String 262 | Dim arg3 As String 263 | ' 264 | arg1 = "the index of the column to be used for filtering" 265 | arg2 = "the 2D array that needs filtering" 266 | arg3 = "'text operator' and 'comparison value(s)' pairs" & vbNewLine _ 267 | & "text operator: =, <, >, <=, >=, <>, IN , NOT IN, LIKE, NOT LIKE" _ 268 | & vbNewLine & "comparison value(s). LIKE and NOT LIKE accept arrays" _ 269 | ' 270 | Application.MacroOptions Macro:="DM_FILTER" _ 271 | , Description:="Filters a 2D array/range by the specified column index" _ 272 | , ArgumentDescriptions:=Array(arg1, arg2, arg3) 273 | End Sub 274 | Private Sub UnregisterDMFilter() 275 | Application.MacroOptions Macro:="DM_FILTER", Description:=Empty _ 276 | , ArgumentDescriptions:=Array(Empty, Empty, Empty) 277 | End Sub 278 | 279 | '******************************************************************************* 280 | 'Inserts rows in a 2D Array or a 1-Area Range before the specified row index 281 | 'Parameters: 282 | ' - arr: a 2D array to insert into 283 | ' - rowsCount: the number of rows to insert 284 | ' - beforeRow: the index of the row before which rows will be inserted 285 | 'Notes: 286 | ' - uses LibArrayTools functions: 287 | ' * GetArrayDimsCount 288 | ' * InsertRowsAtIndex 289 | ' * OneDArrayTo2DArray 290 | ' * ReplaceEmptyInArray 291 | ' - single values are converted to 1-element 1D array 292 | ' - 1D arrays are converted to 1-row 2D arrays 293 | '******************************************************************************* 294 | Public Function DM_INSERT(ByRef arr As Variant, ByVal rowsCount As Long _ 295 | , ByVal beforeRow As Long _ 296 | ) As Variant 297 | Application.Volatile False 298 | #If USE_LIB_FAST_UDFS Then 299 | LibUDFs.TriggerFastUDFCalculation 300 | #End If 301 | ' 302 | 'Only accept 1-Area Ranges. This could alternatively be changed to ignore 303 | ' the extra Areas by arr = arr.Areas(1).Value2 instead of the 2 lines 304 | If VBA.TypeName(arr) = "Range" Then 305 | If arr.Areas.Count > 1 Then GoTo FailInput 306 | arr = arr.Value2 307 | End If 308 | ' 309 | 'Convert single value to 1-element 1D array 310 | If Not VBA.IsArray(arr) Then arr = Array(arr) 311 | ' 312 | Select Case LibArrayTools.GetArrayDimsCount(arr) 313 | Case 2 314 | 'Continue 315 | Case 1 'Convert to 1-row 2D array and adjust beforeRow index 316 | Dim colsCount As Long: colsCount = UBound(arr) - LBound(arr) + 1 317 | arr = LibArrayTools.OneDArrayTo2DArray(arr, colsCount) 318 | beforeRow = beforeRow + LBound(arr, 1) - 1 319 | Case Else 320 | GoTo FailInput 'Should not happen if called from Excel 321 | End Select 322 | On Error GoTo ErrorHandler 323 | DM_INSERT = LibArrayTools.InsertRowsAtIndex(arr, rowsCount, beforeRow) 324 | ' 325 | 'Replace the special value Empty with empty String so it is not returned 326 | ' as 0 (zero) in the caller Range 327 | LibArrayTools.ReplaceEmptyInArray DM_INSERT, vbNullString 328 | Exit Function 329 | ErrorHandler: 330 | FailInput: 331 | DM_INSERT = VBA.CVErr(xlErrValue) 332 | End Function 333 | 334 | '############################################################################### 335 | 'Help for the Function Arguments Dialog in Excel - DM_INSERT 336 | '############################################################################### 337 | Private Sub RegisterDMInsert() 338 | Dim arg1 As String 339 | Dim arg2 As String 340 | Dim arg3 As String 341 | ' 342 | arg1 = "a 2D array to insert into. 1D arrays are considered 1-row 2D" 343 | arg2 = "the number of rows to insert" 344 | arg3 = "the index of the row before which rows will be inserted" 345 | ' 346 | Application.MacroOptions Macro:="DM_INSERT" _ 347 | , Description:="Inserts rows in a 2D Array" _ 348 | , ArgumentDescriptions:=Array(arg1, arg2, arg3) 349 | End Sub 350 | Private Sub UnRegisterDMInsert() 351 | Application.MacroOptions Macro:="DM_INSERT", Description:=Empty _ 352 | , ArgumentDescriptions:=Array(Empty, Empty, Empty) 353 | End Sub 354 | 355 | '******************************************************************************* 356 | 'Inserts rows in a 2D Array between rows with different values (on the specified 357 | ' column) and optionally at the top and/or bottom of the array 358 | 'Parameters: 359 | ' - arr: a 2D array to insert into 360 | ' - rowsCount: the number of rows to insert at each value change 361 | ' - columnIndex: the index of the column used for row comparison 362 | ' - [topRowsCount]: number of rows to insert before array. Default is 0 363 | ' - [bottomRowsCount]: number of rows to insert after array. Default is 0 364 | 'Notes: 365 | ' - uses LibArrayTools functions: 366 | ' * GetArrayDimsCount 367 | ' * InsertRowsAtValChange 368 | ' * OneDArrayTo2DArray 369 | ' * ReplaceEmptyInArray 370 | ' - single values are converted to 1-element 1D array 371 | ' - 1D arrays are converted to 1-row 2D arrays 372 | '******************************************************************************* 373 | Public Function DM_INSERT2(ByRef arr As Variant _ 374 | , ByVal rowsCount As Long, ByVal columnIndex As Long _ 375 | , Optional ByVal topRowsCount As Long = 0 _ 376 | , Optional ByVal bottomRowsCount As Long = 0 _ 377 | ) As Variant 378 | Attribute DM_INSERT2.VB_Description = "Inserts rows in a 2D Array between rows with different values (on the specified column) and optionally at the top and/or bottom of the array" 379 | Attribute DM_INSERT2.VB_ProcData.VB_Invoke_Func = " \n14" 380 | Application.Volatile False 381 | #If USE_LIB_FAST_UDFS Then 382 | LibUDFs.TriggerFastUDFCalculation 383 | #End If 384 | ' 385 | 'Only accept 1-Area Ranges. This could alternatively be changed to ignore 386 | ' the extra Areas by arr = arr.Areas(1).Value2 instead of the 2 lines 387 | If VBA.TypeName(arr) = "Range" Then 388 | If arr.Areas.Count > 1 Then GoTo FailInput 389 | arr = arr.Value2 390 | End If 391 | ' 392 | 'Convert single value to 1-element 1D array 393 | If Not VBA.IsArray(arr) Then arr = Array(arr) 394 | ' 395 | Select Case LibArrayTools.GetArrayDimsCount(arr) 396 | Case 2 'Continue 397 | Case 1 'Convert to 1-row 2D array and adjust column index 398 | Dim colsCount As Long: colsCount = UBound(arr) - LBound(arr) + 1 399 | arr = LibArrayTools.OneDArrayTo2DArray(arr, colsCount) 400 | columnIndex = columnIndex + LBound(arr, 2) - 1 401 | Case Else 402 | GoTo FailInput 'Should not happen if called from Excel 403 | End Select 404 | On Error GoTo ErrorHandler 405 | DM_INSERT2 = LibArrayTools.InsertRowsAtValChange( _ 406 | arr, rowsCount, columnIndex, topRowsCount, bottomRowsCount) 407 | ' 408 | 'Replace the special value Empty with empty String so it is not returned 409 | ' as 0 (zero) in the caller Range 410 | LibArrayTools.ReplaceEmptyInArray DM_INSERT2, vbNullString 411 | Exit Function 412 | ErrorHandler: 413 | FailInput: 414 | DM_INSERT2 = VBA.CVErr(xlErrValue) 415 | End Function 416 | 417 | '############################################################################### 418 | 'Help for the Function Arguments Dialog in Excel - DM_INSERT2 419 | '############################################################################### 420 | Private Sub RegisterDMInsert2() 421 | Dim arg1 As String 422 | Dim arg2 As String 423 | Dim arg3 As String 424 | Dim arg4 As String 425 | Dim arg5 As String 426 | ' 427 | arg1 = "a 2D array to insert into. 1D arrays are considered 1-row 2D" 428 | arg2 = "the number of rows to insert at each value change" 429 | arg3 = "the index of the column used for row comparison" 430 | arg4 = "[Optional]" & vbNewLine _ 431 | & "the number of rows to insert at the top of the array. Default is 0" 432 | arg5 = "[Optional]" & vbNewLine _ 433 | & "the number of rows to insert at the bottom of the array. Default is 0" 434 | ' 435 | Application.MacroOptions Macro:="DM_INSERT2" _ 436 | , Description:="Inserts rows in a 2D Array between rows with " _ 437 | & "different values (on the specified column) and optionally at " _ 438 | & "the top and/or bottom of the array" _ 439 | , ArgumentDescriptions:=Array(arg1, arg2, arg3, arg4, arg5) 440 | End Sub 441 | Private Sub UnRegisterDMInsert2() 442 | Application.MacroOptions Macro:="DM_INSERT2", Description:=Empty _ 443 | , ArgumentDescriptions:=Array(Empty, Empty, Empty, Empty, Empty) 444 | End Sub 445 | 446 | '******************************************************************************* 447 | 'Merges/Combines two 1D/2D Arrays or 1-Area Ranges 448 | 'Returns: 449 | ' - the merged array or the Excel #VALUE! error 450 | 'Parameters: 451 | ' - arr1: the first 1D/2D Array 452 | ' - arr2: the second 1D/2D Array 453 | ' - [verticalMerge]: 454 | ' * TRUE - arrays are combined vertically 455 | ' * FALSE - arrays are combined horizontally (default) 456 | 'Notes: 457 | ' - single values are converted to 1-element 1D array 458 | ' - 1D arrays are converted to 1-row 2D arrays 459 | ' - uses LibArrayTools functions: 460 | ' * GetArrayDimsCount 461 | ' * Merge2DArrays 462 | ' * OneDArrayTo2DArray 463 | ' * ReplaceEmptyInArray 464 | '******************************************************************************* 465 | Public Function DM_MERGE(ByRef arr1 As Variant, ByRef arr2 As Variant _ 466 | , Optional ByVal verticalMerge As Boolean = False _ 467 | ) As Variant 468 | Attribute DM_MERGE.VB_Description = "Merges/Combines two 1D/2D Arrays" 469 | Attribute DM_MERGE.VB_ProcData.VB_Invoke_Func = " \n14" 470 | Application.Volatile False 471 | #If USE_LIB_FAST_UDFS Then 472 | LibUDFs.TriggerFastUDFCalculation 473 | #End If 474 | ' 475 | 'Only accept 1-Area Ranges. This could alternatively be changed to ignore 476 | ' the extra Areas by arr = arr.Areas(1).Value2 instead of the 2 lines 477 | If VBA.TypeName(arr1) = "Range" Then 478 | If arr1.Areas.Count > 1 Then GoTo FailInput 479 | arr1 = arr1.Value2 480 | End If 481 | If VBA.TypeName(arr2) = "Range" Then 482 | If arr2.Areas.Count > 1 Then GoTo FailInput 483 | arr2 = arr2.Value2 484 | End If 485 | ' 486 | 'Convert single value to 1-element 1D array 487 | If Not VBA.IsArray(arr1) Then arr1 = Array(arr1) 488 | If Not VBA.IsArray(arr2) Then arr2 = Array(arr2) 489 | ' 490 | Dim columnsCount As Long 491 | ' 492 | 'Convert 1D arrays to 1-row 2D arrays 493 | If LibArrayTools.GetArrayDimsCount(arr1) = 1 Then 494 | columnsCount = UBound(arr1) - LBound(arr1) + 1 495 | arr1 = LibArrayTools.OneDArrayTo2DArray(arr1, columnsCount) 496 | End If 497 | If LibArrayTools.GetArrayDimsCount(arr2) = 1 Then 498 | columnsCount = UBound(arr2) - LBound(arr2) + 1 499 | arr2 = LibArrayTools.OneDArrayTo2DArray(arr2, columnsCount) 500 | End If 501 | ' 502 | On Error GoTo ErrorHandler 503 | DM_MERGE = LibArrayTools.Merge2DArrays(arr1, arr2, verticalMerge) 504 | ' 505 | 'Replace the special value Empty with empty String so it is not returned 506 | ' as 0 (zero) in the caller Range 507 | LibArrayTools.ReplaceEmptyInArray DM_MERGE, vbNullString 508 | Exit Function 509 | ErrorHandler: 510 | FailInput: 511 | DM_MERGE = VBA.CVErr(xlErrValue) 512 | End Function 513 | 514 | '############################################################################### 515 | 'Help for the Function Arguments Dialog in Excel - DM_MERGE 516 | '############################################################################### 517 | Private Sub RegisterDMMerge() 518 | Dim arg1 As String 519 | Dim arg2 As String 520 | Dim arg3 As String 521 | ' 522 | arg1 = "the first 1D/2D Array. 1D arrays are considered 1-row 2D" 523 | arg2 = "the second 1D/2D Array. 1D arrays are considered 1-row 2D" 524 | arg3 = "[Optional]" & vbNewLine & "True - arrays are combined vertically" _ 525 | & vbNewLine & "False - arrays are combined horizontally (Default)" 526 | ' 527 | Application.MacroOptions Macro:="DM_MERGE" _ 528 | , Description:="Merges/Combines two 1D/2D Arrays" _ 529 | , ArgumentDescriptions:=Array(arg1, arg2, arg3) 530 | End Sub 531 | Private Sub UnregisterDMMerge() 532 | Application.MacroOptions Macro:="DM_MERGE", Description:=Empty _ 533 | , ArgumentDescriptions:=Array(Empty, Empty, Empty) 534 | End Sub 535 | 536 | '******************************************************************************* 537 | 'Reverses (in groups) a 1D/2D Array or a 1-Area Range 538 | 'Returns: 539 | ' - the reversed array or the Excel #VALUE! error 540 | 'Parameters: 541 | ' - arr: a 1D/2D Array or Range of values to be reversed 542 | ' - [groupSize]: the number of values in each group 543 | ' - [verticalFlip]: 544 | ' * TRUE - reverse vertically 545 | ' * FALSE - reverse horizontally (default) 546 | 'Examples: 547 | ' - arr = [1,2,3,4], groupSize = 1, verticalFlip = True > return is [1,2,3,4] 548 | ' - arr = [1,2,3,4], groupSize = 1, verticalFlip = False > return is [4,3,2,1] 549 | ' - arr = [1,2,3,4], groupSize = 2, verticalFlip = False > return is [3,4,1,2] 550 | ' - arr = [1,2,3,4], groupSize = 2, verticalFlip = False > return is [3,4,1,2] 551 | ' [5,6,7,8] [7,8,5,6] 552 | ' - arr = [1,2,3,4], groupSize = 1, verticalFlip = True > return is [5,6,7,8] 553 | ' [5,6,7,8] [1,2,3,4] 554 | 'Notes: 555 | ' - single values are converted to 1-element 1D array 556 | ' - uses LibArrayTools functions: 557 | ' * GetArrayDimsCount 558 | ' * ReplaceEmptyInArray 559 | ' * Reverse1DArray 560 | ' * Reverse2DArray 561 | '******************************************************************************* 562 | Public Function DM_REVERSE(ByRef arr As Variant _ 563 | , Optional ByVal groupSize As Long = 1 _ 564 | , Optional ByVal verticalFlip As Boolean = False _ 565 | ) As Variant 566 | Attribute DM_REVERSE.VB_Description = "Reverses (in groups) a 2D Array or a 1-Area Range" 567 | Attribute DM_REVERSE.VB_ProcData.VB_Invoke_Func = " \n14" 568 | Application.Volatile False 569 | #If USE_LIB_FAST_UDFS Then 570 | LibUDFs.TriggerFastUDFCalculation 571 | #End If 572 | ' 573 | 'Only accept 1-Area Ranges. This could alternatively be changed to ignore 574 | ' the extra Areas by arr = arr.Areas(1).Value2 instead of the 2 lines 575 | If VBA.TypeName(arr) = "Range" Then 576 | If arr.Areas.Count > 1 Then GoTo FailInput 577 | arr = arr.Value2 578 | End If 579 | ' 580 | 'Convert single value to 1-element 1D array 581 | If Not VBA.IsArray(arr) Then arr = Array(arr) 582 | ' 583 | On Error GoTo ErrorHandler 584 | Select Case LibArrayTools.GetArrayDimsCount(arr) 585 | Case 1 586 | If Not verticalFlip Then LibArrayTools.Reverse1DArray arr, groupSize 587 | Case 2 588 | LibArrayTools.Reverse2DArray arr, groupSize, verticalFlip 589 | Case Else 590 | GoTo FailInput 'Should not happen if called from Excel 591 | End Select 592 | ' 593 | 'Replace the special value Empty with empty String so it is not returned 594 | ' as 0 (zero) in the caller Range 595 | LibArrayTools.ReplaceEmptyInArray arr, vbNullString 596 | ' 597 | DM_REVERSE = arr 598 | Exit Function 599 | ErrorHandler: 600 | FailInput: 601 | DM_REVERSE = VBA.CVErr(xlErrValue) 602 | End Function 603 | 604 | '############################################################################### 605 | 'Help for the Function Arguments Dialog in Excel - DM_REVERSE 606 | '############################################################################### 607 | Private Sub RegisterDMReverse() 608 | Dim arg1 As String 609 | Dim arg2 As String 610 | Dim arg3 As String 611 | ' 612 | arg1 = "a 1D/2D Array or Range of values to be reversed" & vbNewLine _ 613 | & "1D arrays are considered 1-row 2D" 614 | arg2 = "[Optional]" & vbNewLine _ 615 | & "the number of values in each group. Default is 1" 616 | arg3 = "[Optional]" & vbNewLine & "True - reverse vertically" _ 617 | & vbNewLine & "False - reverse horizontally (Default)" 618 | ' 619 | Application.MacroOptions Macro:="DM_REVERSE" _ 620 | , Description:="Reverses (in groups) a 2D Array or a 1-Area Range" _ 621 | , ArgumentDescriptions:=Array(arg1, arg2, arg3) 622 | End Sub 623 | Private Sub UnregisterDMReverse() 624 | Application.MacroOptions Macro:="DM_REVERSE", Description:=Empty _ 625 | , ArgumentDescriptions:=Array(Empty, Empty, Empty) 626 | End Sub 627 | 628 | '******************************************************************************* 629 | 'Creates an arithmetic progression sequence as a 2D array 630 | 'Returns: 631 | ' - the arithmetic progression or the Excel #VALUE! error 632 | 'Parameters: 633 | ' - rowsCount: the number of rows in the output 2D Array 634 | ' - [columnsCount]: the number of columns in the output 2D Array 635 | ' - [initialTerm]: the value of the first term 636 | ' - [commonDifference]: the difference between any 2 consecutive terms 637 | 'Notes: 638 | ' - uses LibArrayTools functions: 639 | ' * Sequence2D 640 | '******************************************************************************* 641 | Public Function DM_SEQUENCE(ByVal rowsCount As Long _ 642 | , Optional ByVal columnsCount As Long = 1 _ 643 | , Optional ByVal initialTerm As Double = 1 _ 644 | , Optional ByVal commonDifference As Double = 1 _ 645 | ) As Variant 646 | Attribute DM_SEQUENCE.VB_Description = "Returns an arithmetic progression sequence as 2D array" 647 | Attribute DM_SEQUENCE.VB_ProcData.VB_Invoke_Func = " \n14" 648 | Application.Volatile False 649 | #If USE_LIB_FAST_UDFS Then 650 | LibUDFs.TriggerFastUDFCalculation 651 | #End If 652 | ' 653 | On Error GoTo ErrorHandler 654 | DM_SEQUENCE = LibArrayTools.Sequence2D(rowsCount * columnsCount, initialTerm _ 655 | , commonDifference, columnsCount) 656 | Exit Function 657 | ErrorHandler: 658 | DM_SEQUENCE = VBA.CVErr(xlErrValue) 659 | End Function 660 | 661 | '############################################################################### 662 | 'Help for the Function Arguments Dialog in Excel - DM_SEQUENCE 663 | '############################################################################### 664 | Private Sub RegisterDMSequence() 665 | Dim arg1 As String 666 | Dim arg2 As String 667 | Dim arg3 As String 668 | Dim arg4 As String 669 | ' 670 | arg1 = "number of rows in the output 2D Array" 671 | arg2 = "[Optional]" & vbNewLine & "number of output columns. Default is 1" 672 | arg3 = "[Optional]" & vbNewLine & "value of the first term. Default is 1" 673 | arg4 = "[Optional]" & vbNewLine _ 674 | & "difference between any 2 consecutive terms. Default is 1" 675 | ' 676 | Application.MacroOptions Macro:="DM_SEQUENCE " _ 677 | , Description:="Returns an arithmetic progression sequence as 2D array" _ 678 | , ArgumentDescriptions:=Array(arg1, arg2, arg3, arg4) 679 | End Sub 680 | Private Sub UnregisterDMSequence() 681 | Application.MacroOptions Macro:="DM_SEQUENCE ", Description:=Empty _ 682 | , ArgumentDescriptions:=Array(Empty, Empty, Empty, Empty) 683 | End Sub 684 | 685 | '******************************************************************************* 686 | 'Slices a 1D/2D Array or a 1-Area Range 687 | 'Returns: 688 | ' - the array slice or an Excel #VALUE! or #REF! error 689 | 'Parameters: 690 | ' - arr: a 1D/2D array to slice 691 | ' - startRow: the index of the first row to be added to result 692 | ' - startColumn: the index of the first column to be added to result 693 | ' - [height_]: the number of rows to be returned. Default is 1. 694 | ' Use 0 to get all rows starting from startRow 695 | ' - [width_]: the number of columns to be returned. Default is 1. 696 | ' Use 0 to get all columns starting from startColumn 697 | 'Notes: 698 | ' - excess height or width is ignored 699 | ' - uses LibArrayTools functions: 700 | ' * GetArrayDimsCount 701 | ' * ReplaceEmptyInArray 702 | ' * Slice1DArray 703 | ' * Slice2DArray 704 | ' - single values are converted to 1-element 1D array 705 | '******************************************************************************* 706 | Public Function DM_SLICE(ByRef arr As Variant _ 707 | , ByVal startRow As Long, ByVal startColumn As Long _ 708 | , Optional ByVal height_ As Long = 1, Optional ByVal width_ As Long = 1 _ 709 | ) As Variant 710 | Attribute DM_SLICE.VB_Description = "Slices a 1D/2D Array or a 1-Area Range" 711 | Attribute DM_SLICE.VB_ProcData.VB_Invoke_Func = " \n14" 712 | Application.Volatile False 713 | #If USE_LIB_FAST_UDFS Then 714 | LibUDFs.TriggerFastUDFCalculation 715 | #End If 716 | ' 717 | 'Only accept 1-Area Ranges. This could alternatively be changed to ignore 718 | ' the extra Areas by arr = arr.Areas(1).Value2 instead of the 2 lines 719 | If VBA.TypeName(arr) = "Range" Then 720 | If arr.Areas.Count > 1 Then GoTo FailInput 721 | arr = arr.Value2 722 | End If 723 | ' 724 | 'Convert single value to 1-element 1D array 725 | If Not VBA.IsArray(arr) Then 726 | arr = Array(arr) 727 | startColumn = startColumn + LBound(arr) - 1 728 | End If 729 | ' 730 | On Error GoTo FailReference 731 | Select Case LibArrayTools.GetArrayDimsCount(arr) 732 | Case 1 733 | If startRow <> 1 Or height_ < 0 Then GoTo FailReference 734 | If width_ = 0 Then width_ = UBound(arr) - startColumn + 1 735 | DM_SLICE = LibArrayTools.Slice1DArray(arr, startColumn, width_) 736 | Case 2 737 | If height_ = 0 Then height_ = UBound(arr, 1) - startRow + 1 738 | If width_ = 0 Then width_ = UBound(arr, 2) - startColumn + 1 739 | DM_SLICE = LibArrayTools.Slice2DArray(arr, startRow, startColumn _ 740 | , height_, width_) 741 | Case Else 742 | GoTo FailInput 'Should not happen if called from Excel 743 | End Select 744 | ' 745 | 'Replace the special value Empty with empty String so it is not returned 746 | ' as 0 (zero) in the caller Range 747 | LibArrayTools.ReplaceEmptyInArray DM_SLICE, vbNullString 748 | Exit Function 749 | FailInput: 750 | DM_SLICE = VBA.CVErr(xlErrValue) 751 | Exit Function 752 | FailReference: 753 | DM_SLICE = VBA.CVErr(xlErrRef) 754 | End Function 755 | 756 | '############################################################################### 757 | 'Help for the Function Arguments Dialog in Excel - DM_SLICE 758 | '############################################################################### 759 | Private Sub RegisterDMSlice() 760 | Dim arg1 As String 761 | Dim arg2 As String 762 | Dim arg3 As String 763 | Dim arg4 As String 764 | Dim arg5 As String 765 | ' 766 | arg1 = "a 1D/2D array to slice. 1D arrays can be viewed as 1-row 2D" 767 | arg2 = "the index of the first row to be added to result" 768 | arg3 = "the index of the first column to be added to result" 769 | arg4 = "[Optional]" & vbNewLine _ 770 | & "the number of rows to be returned. Default is 1. " _ 771 | & "Use 0 to get all rows starting from startRow" 772 | arg5 = "[Optional]" & vbNewLine _ 773 | & "the number of columns to be returned. Default is 1" _ 774 | & "Use 0 to get all columns starting from startColumn" 775 | ' 776 | Application.MacroOptions Macro:="DM_SLICE" _ 777 | , Description:="Slices a 1D/2D Array or a 1-Area Range" _ 778 | , ArgumentDescriptions:=Array(arg1, arg2, arg3, arg4, arg5) 779 | End Sub 780 | Private Sub UnregisterDMSlice() 781 | Application.MacroOptions Macro:="DM_SLICE", Description:=Empty _ 782 | , ArgumentDescriptions:=Array(Empty, Empty, Empty, Empty, Empty) 783 | End Sub 784 | 785 | '******************************************************************************* 786 | 'Sorts a 1D/2D Array or a 1-Area Range 787 | 'Returns: 788 | ' - the sorted array or the Excel #VALUE! error 789 | 'Parameters: 790 | ' - arr: a 1D/2D Array or Range of values to sort 791 | ' - [sortIndex]: the index of the column/row used for sorting 792 | ' - [sortAscending]: 793 | ' * TRUE - Ascending (default) 794 | ' * FALSE - Descending 795 | ' - [sortTextNumberAsNumber]: 796 | ' * TRUE - numbers stored as texts are considered numbers (default) 797 | ' * FALSE - numbers stored as texts are considered texts 798 | ' - [caseSensitiveTexts]: 799 | ' * TRUE - compare texts as case-sensitive 800 | ' * FALSE - ignore case when comparing texts (default) 801 | ' - [verticalSort]: 802 | ' * TRUE - sorts vertically (by column) (default) 803 | ' * FALSE - sorts horizontally (by row) 804 | 'Notes: 805 | ' - single values are converted to 1-element 1D array 806 | ' - when sorting a 1D array vertically, the array is regarded as a 1-row 2D 807 | ' array and is returned as-is 808 | ' - when sorting a 1D array the sortIndex is not used but must be 1 or omitted 809 | ' - when sorting a 2D array horizontally, the array is first transposed, then 810 | ' sorted by column and finally transposed back with the end result being 811 | ' that the array was actually sorted by row 812 | ' - uses LibArrayTools functions: 813 | ' * GetArrayDimsCount 814 | ' * ReplaceEmptyInArray 815 | ' * Sort1DArray 816 | ' * Sort2DArray 817 | ' * TransposeArray 818 | '******************************************************************************* 819 | Public Function DM_SORT(ByRef arr As Variant _ 820 | , Optional ByVal sortIndex As Long = 1 _ 821 | , Optional ByVal sortAscending As Boolean = True _ 822 | , Optional ByVal sortTextNumberAsNumber As Boolean = True _ 823 | , Optional ByVal caseSensitiveTexts As Boolean = False _ 824 | , Optional ByVal verticalSort As Boolean = True _ 825 | ) As Variant 826 | Attribute DM_SORT.VB_Description = "Sorts a 1D/2D Array or a 1-Area Range" 827 | Attribute DM_SORT.VB_ProcData.VB_Invoke_Func = " \n14" 828 | Application.Volatile False 829 | #If USE_LIB_FAST_UDFS Then 830 | LibUDFs.TriggerFastUDFCalculation 831 | #End If 832 | ' 833 | 'Only accept 1-Area Ranges. This could alternatively be changed to ignore 834 | ' the extra Areas by arr = arr.Areas(1).Value2 instead of the 2 lines 835 | If VBA.TypeName(arr) = "Range" Then 836 | If arr.Areas.Count > 1 Then GoTo FailInput 837 | arr = arr.Value2 838 | End If 839 | ' 840 | 'Convert single value to 1-element 1D array 841 | If Not VBA.IsArray(arr) Then 842 | arr = Array(arr) 843 | sortIndex = sortIndex + LBound(arr) - 1 844 | End If 845 | ' 846 | Select Case LibArrayTools.GetArrayDimsCount(arr) 847 | Case 1 848 | If verticalSort Then 849 | 'Still check if column index is valid 850 | If sortIndex < LBound(arr) Then GoTo FailInput 851 | If sortIndex > UBound(arr) Then GoTo FailInput 852 | Else 853 | 'You can only sort by row one since it's the only row 854 | If sortIndex <> 1 Then GoTo FailInput 855 | LibArrayTools.Sort1DArray arr, sortAscending _ 856 | , sortTextNumberAsNumber, caseSensitiveTexts 857 | End If 858 | Case 2 859 | 'Transpose twice for horizontal sort 860 | If Not verticalSort Then arr = LibArrayTools.TransposeArray(arr) 861 | On Error GoTo ErrorHandler 862 | LibArrayTools.Sort2DArray arr, sortIndex, sortAscending _ 863 | , sortTextNumberAsNumber, caseSensitiveTexts 864 | If Not verticalSort Then arr = LibArrayTools.TransposeArray(arr) 865 | Case Else 866 | GoTo FailInput 'Should not happen if called from Excel 867 | End Select 868 | ' 869 | 'Replace the special value Empty with empty String so it is not returned 870 | ' as 0 (zero) in the caller Range 871 | LibArrayTools.ReplaceEmptyInArray arr, vbNullString 872 | ' 873 | DM_SORT = arr 874 | Exit Function 875 | ErrorHandler: 876 | FailInput: 877 | DM_SORT = VBA.CVErr(xlErrValue) 878 | End Function 879 | 880 | '############################################################################### 881 | 'Help for the Function Arguments Dialog in Excel - DM_SORT 882 | '############################################################################### 883 | Private Sub RegisterDMSort() 884 | Dim arg1 As String 885 | Dim arg2 As String 886 | Dim arg3 As String 887 | Dim arg4 As String 888 | Dim arg5 As String 889 | Dim arg6 As String 890 | ' 891 | arg1 = "the array/range to sort" 892 | arg2 = "[Optional]" & vbNewLine & "the column/row to sort by. Default is 1" 893 | arg3 = "[Optional]" & vbNewLine & "True - Ascending (Default)" _ 894 | & vbNewLine & "False - Descending" 895 | arg4 = "[Optional]" & vbNewLine _ 896 | & "True - Sort anything that looks as a number, as a number (Default)" _ 897 | & vbNewLine & "False - Sort numbers stored as text as text" 898 | arg5 = "[Optional]" & vbNewLine & "True - Case Sensitive Texts" _ 899 | & vbNewLine & "False - Case Insensitive Texts (Default)" 900 | arg6 = "[Optional]" & vbNewLine & "True - Sort Vertically (Default)" _ 901 | & vbNewLine & "False - Sort Horizontally" 902 | ' 903 | Application.MacroOptions Macro:="DM_SORT" _ 904 | , Description:="Sorts a 1D/2D Array or a 1-Area Range" _ 905 | , ArgumentDescriptions:=Array(arg1, arg2, arg3, arg4, arg5, arg6) 906 | End Sub 907 | Private Sub UnregisterDMSort() 908 | Application.MacroOptions Macro:="DM_SORT", Description:=Empty _ 909 | , ArgumentDescriptions:=Array(Empty, Empty, Empty, Empty, Empty, Empty) 910 | End Sub 911 | 912 | '******************************************************************************* 913 | 'Returns: 914 | ' - a 1D/2D (based on input) Array of unique values 915 | 'Parameters: 916 | ' - arr: a 1D/2D Array or Range of values to uniquify 917 | ' - [indexes]: the column/row index(es) to be used. 0 (default) - use all 918 | ' - [byColumn]: 919 | ' * TRUE - uniquifies vertically (by column) (default) 920 | ' * FALSE - uniquifies horizontally (by row) 921 | 'Notes: 922 | ' - when uniquifing a 1D array vertically (by column), the array is regarded 923 | ' as a 1-row 2D array and is returned as-is 924 | ' - when uniquifing a 1D array by row, indexes must be 0, 1 or omitted (0) 925 | ' - when uniquifing a 2D array by row, the array is first transposed, then 926 | ' uniquified by column and finally transposed back with the end result being 927 | ' that the array was actually uniquified by row 928 | ' - uses LibArrayTools functions 929 | ' * GetArrayDimsCount 930 | ' * GetUniqueIntegers 931 | ' * GetUniqueRows 932 | ' * GetUniqueValues 933 | ' * IntegerRange1D 934 | ' * ReplaceEmptyInArray 935 | ' * TransposeArray 936 | ' * ValuesToCollection 937 | '******************************************************************************* 938 | Public Function DM_UNIQUE(ByRef arr As Variant _ 939 | , Optional ByVal indexes As Variant = 0 _ 940 | , Optional ByVal byColumn As Boolean = True _ 941 | ) As Variant 942 | Attribute DM_UNIQUE.VB_Description = "Returns a 1D/2D Array of unique values" 943 | Attribute DM_UNIQUE.VB_ProcData.VB_Invoke_Func = " \n14" 944 | Application.Volatile False 945 | #If USE_LIB_FAST_UDFS Then 946 | LibUDFs.TriggerFastUDFCalculation 947 | #End If 948 | ' 949 | 'Only accept 1-Area Ranges. This could alternatively be changed to ignore 950 | ' the extra Areas by arr = arr.Areas(1).Value2 instead of the 2 lines 951 | If VBA.TypeName(arr) = "Range" Then 952 | If arr.Areas.Count > 1 Then GoTo FailInput 953 | arr = arr.Value2 954 | End If 955 | ' 956 | 'Convert single value to 1-element 1D array with lower bound set to 1 957 | If Not VBA.IsArray(arr) Then 958 | Dim tempArr(1 To 1) As Variant 959 | tempArr(1) = arr 960 | arr = tempArr 961 | End If 962 | ' 963 | Dim dimensions As Long: dimensions = LibArrayTools.GetArrayDimsCount(arr) 964 | Dim minIndex As Long 965 | Dim maxIndex As Long 966 | ' 967 | 'Establish the minimum and maximum allowed indexes 968 | Select Case dimensions 969 | Case 1 970 | If byColumn Then minIndex = LBound(arr) Else minIndex = 1 971 | If byColumn Then maxIndex = UBound(arr) Else maxIndex = 1 972 | Case 2 973 | If byColumn Then minIndex = LBound(arr, 2) Else minIndex = LBound(arr, 1) 974 | If byColumn Then maxIndex = UBound(arr, 2) Else maxIndex = UBound(arr, 1) 975 | Case Else 976 | GoTo FailInput 'Should not happen if called from Excel 977 | End Select 978 | ' 979 | Dim useAllIndexes As Boolean 980 | Dim uniqueIndexes() As Long 981 | ' 982 | 'Check if all indexes are used 983 | If VBA.IsNumeric(indexes) Then useAllIndexes = (indexes = 0) 984 | ' 985 | 'Create array of integer indexes 986 | On Error GoTo ErrorHandler 987 | If useAllIndexes Then 988 | uniqueIndexes = LibArrayTools.IntegerRange1D(minIndex, maxIndex) 989 | Else 990 | uniqueIndexes = LibArrayTools.GetUniqueIntegers( _ 991 | LibArrayTools.ValuesToCollection(indexes, nestNone, columnWise) _ 992 | , minIndex, maxIndex) 993 | End If 994 | ' 995 | 'Get Unique Rows/Values 996 | If dimensions = 1 Then 997 | If byColumn Then 998 | DM_UNIQUE = arr 999 | Else 1000 | DM_UNIQUE = LibArrayTools.GetUniqueValues(arr) 1001 | End If 1002 | Else '2 dimensions 1003 | If Not byColumn Then arr = LibArrayTools.TransposeArray(arr) 1004 | DM_UNIQUE = LibArrayTools.GetUniqueRows(arr, uniqueIndexes) 1005 | If Not byColumn Then DM_UNIQUE = LibArrayTools.TransposeArray(DM_UNIQUE) 1006 | End If 1007 | ' 1008 | 'Replace the special value Empty with empty String so it is not returned 1009 | ' as 0 (zero) in the caller Range 1010 | LibArrayTools.ReplaceEmptyInArray DM_UNIQUE, vbNullString 1011 | Exit Function 1012 | ErrorHandler: 1013 | FailInput: 1014 | DM_UNIQUE = VBA.CVErr(xlErrValue) 1015 | End Function 1016 | 1017 | '############################################################################### 1018 | 'Help for the Function Arguments Dialog in Excel - DM_UNIQUE 1019 | '############################################################################### 1020 | Private Sub RegisterDMUnique() 1021 | Dim arg1 As String 1022 | Dim arg2 As String 1023 | Dim arg3 As String 1024 | ' 1025 | arg1 = "a 1D/2D Array or Range of values to uniquify" 1026 | arg2 = "[Optional]" & vbNewLine & _ 1027 | " the column/row index(es) to be used. Default is 0 (use all)" _ 1028 | & vbNewLine & "Can be a list of more indexes (array/range)" 1029 | arg3 = "[Optional]" & vbNewLine _ 1030 | & "True - uniquifies vertically (by column) (Default)" & vbNewLine _ 1031 | & "False - uniquifies horizontally (by row)" 1032 | ' 1033 | Application.MacroOptions Macro:="DM_UNIQUE" _ 1034 | , Description:="Returns a 1D/2D Array of unique values" _ 1035 | , ArgumentDescriptions:=Array(arg1, arg2, arg3) 1036 | End Sub 1037 | Private Sub UnregisterDMUnique() 1038 | Application.MacroOptions Macro:="DM_UNIQUE", Description:=Empty _ 1039 | , ArgumentDescriptions:=Array(Empty, Empty, Empty) 1040 | End Sub 1041 | --------------------------------------------------------------------------------