├── .github └── FUNDING.yml ├── ArrayFunctions.bas ├── LICENSE ├── README.md └── TestModule.bas /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | # These are supported funding model platforms 2 | 3 | custom: ['https://www.buymeacoffee.com/todar'] 4 | -------------------------------------------------------------------------------- /ArrayFunctions.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "arrayFunctions" 2 | Option Explicit 3 | Option Compare Text 4 | Option Private Module 5 | Option Base 0 6 | 7 | 'ERROR CODES CONSTANTS 8 | Public Const ARRAY_NOT_PASSED_IN As Integer = 5000 9 | Public Const ARRAY_DIMENSION_INCORRECT As Integer = 5001 10 | 11 | '@AUTHOR: ROBERT TODAR 12 | 13 | 'DEPENDENCIES 14 | ' - No dependencies for other modules or library references :) 15 | 16 | 'PUBLIC FUNCTIONS 17 | ' - ArrayAverage 18 | ' - ArrayContainsEmpties 19 | ' - ArrayDimensionLength 20 | ' - ArrayExtractColumn 21 | ' - ArrayExtractRow 22 | ' - ArrayFilter 23 | ' - ArrayFilterTwo 24 | ' - ArrayFromRecordset 25 | ' - ArrayGetColumnIndex 26 | ' - ArrayGetIndexes 27 | ' - ArrayIncludes 28 | ' - ArrayIndexOf 29 | ' - ArrayLength 30 | ' - ArrayPluck 31 | ' - ArrayPop 32 | ' - ArrayPush 33 | ' - ArrayPushTwoDim 34 | ' - ArrayQuery 35 | ' - ArrayRemoveDuplicates 36 | ' - ArrayReverse 37 | ' - ArrayShift 38 | ' - ArraySort 39 | ' - ArraySplice 40 | ' - ArraySpread 41 | ' - ArraySum 42 | ' - ArrayToCSVFile 43 | ' - ArrayToString 44 | ' - ArrayTranspose 45 | ' - ArrayUnShift 46 | ' - Assign 47 | ' - ConvertToArray 48 | ' - IsArrayEmpty 49 | 50 | 'PRIVATE METHODS/FUNCTIONS 51 | ' - 52 | 53 | 'NOTES: 54 | ' - 55 | 56 | 'TODO: 57 | ' - CLEAN UP CODE! ADD MORE NOTES AND EXAMPLES. 58 | ' - NEED TO REALLY TEST ALL OF THESE FUNCTIONS, CHECK FOR ERRORS. 59 | ' - ADD MORE CUSTOM ERROR MESSAGES FOR SPECIFIC ERRORS. 60 | ' 61 | ' - LOOK THROUGH FUNCTIONS DESIGNED FOR SINGLE DIM ARRAYS, SEE IF CAN CONVERT TO WORK 62 | ' WITH 2 DIM AS WELL 63 | ' 64 | ' - Create ArrayConcat function 65 | 66 | 67 | 'EXAMPLES OF VARIOUS FUNCTIONS 68 | Private Sub ArrayFunctionExamples() 69 | 70 | Dim A As Variant 71 | 72 | 'SINGLE DIM FUNCTIONS TO MANIPULATE 73 | ArrayPush A, "Banana", "Apple", "Carrot" '--> Banana,Apple,Carrot 74 | ArrayPop A '--> Banana,Apple --> returns Carrot 75 | ArrayUnShift A, "Mango", "Orange" '--> Mango,Orange,Banana,Apple 76 | ArrayShift A '--> Orange,Banana,Apple 77 | ArraySplice A, 2, 0, "Coffee" '--> Orange,Banana,Coffee,Apple 78 | ArraySplice A, 0, 1, "Mango", "Coffee" '--> Mango,Coffee,Banana,Coffee,Apple 79 | ArrayRemoveDuplicates A '--> Mango,Coffee,Banana,Apple 80 | ArraySort A '--> Apple,Banana,Coffee,Mango 81 | ArrayReverse A '--> Mango,Coffee,Banana,Apple 82 | 83 | 'ARRAY PROPERTIES 84 | ArrayLength A '--> 4 85 | ArrayIndexOf A, "Coffee" '--> 1 86 | ArrayIncludes A, "Banana" '--> True 87 | ArrayContains A, Array("Test", "Banana") '--> True 88 | ArrayContainsEmpties A '--> False 89 | ArrayDimensionLength A '--> 1 (single dim array) 90 | IsArrayEmpty A '--> False 91 | 92 | 'CAN FLATTEN JAGGED ARRAY WITH SPREAD FORMULA 93 | A = Array(1, 2, 3, Array(4, 5, 6, Array(7, 8, 9))) 'COULD ALSO SPREAD DICTIONAIRES AND COLLECTIONS AS WELL 94 | A = ArraySpread(A) '--> 1,2,3,4,5,6,7,8,9 95 | 96 | 'MATH EXAMPLES 97 | ArraySum A '--> 45 98 | ArrayAverage A '--> 5 99 | 100 | 'FILTER USE'S REGEX PATTERN 101 | A = Array("Banana", "Coffee", "Apple", "Carrot", "Canolope") 102 | A = ArrayFilter(A, "^Ca|^Ap") 103 | 104 | 'ARRAY TO STRING WORKS WITH BOTH SINGLE AND DOUBLE DIM ARRAYS! 105 | Debug.Print ArrayToString(A) 106 | 107 | End Sub 108 | 109 | '****************************************************************************************** 110 | ' TESTING SECTION (REALLY ALL CODE NEEDS TO BE TESTED, BUT THESE ARE MUCH LESS PROVEN) 111 | '****************************************************************************************** 112 | 113 | 'TESTER SUB FOR NEW FUNCTIONS 114 | Private Sub ArrayPlayground() 115 | 116 | Dim Arr As Variant 117 | Arr = Array(0, 1, 2, Array(3, 4, 5), Array(6, 7, Array(8, 9, Array(10, 11, 12, 13, Array(14, 15, 16))))) 118 | Arr = ArraySpread(Arr) 119 | 120 | Debug.Print ArrayToString(Arr) 121 | 122 | End Sub 123 | 124 | 'FILTER SINGLE DIM ARRAY ELEMENTS BASED ON REGEX PATTERN 125 | Public Function ArrayFilter(ByVal SourceArray As Variant, ByVal RegExPattern As String) As Variant 126 | 127 | '@AUTHOR: ROBERT TODAR 128 | '@DIM: SINGLE DIM ONLY 129 | '@REF: https://regexr.com/ 130 | '@EXAMPLE: ArrayFilter(Array("Banana", "Coffee", "Apple"), "^Ba|^Ap") -> [Banana,Apple] 131 | 132 | If ArrayDimensionLength(SourceArray) <> 1 Then 133 | Err.Raise ARRAY_DIMENSION_INCORRECT, , "SourceArray must be a single dimensional array." 134 | End If 135 | 136 | Dim RegEx As Object 137 | Set RegEx = CreateObject("vbscript.regexp") 138 | With RegEx 139 | .Global = False 140 | .MultiLine = True 141 | .IgnoreCase = True 142 | .Pattern = RegExPattern 'SET THE PATTERN THAT WAS PASSED IN 143 | End With 144 | 145 | Dim Index As Long 146 | For Index = LBound(SourceArray) To UBound(SourceArray) 147 | 148 | If RegEx.TEST(SourceArray(Index)) Then 149 | ArrayPush ArrayFilter, SourceArray(Index) 150 | End If 151 | 152 | Next Index 153 | 154 | End Function 155 | 156 | 'FILTERS MULTIDIMENSIONAL ARRAY. ARGS ARE PAIR BASED: (HEADING TITLE, REGEX) https://regexr.com/ for help 157 | Public Function ArrayFilterTwo(ByVal SourceArray As Variant, ParamArray Args() As Variant) As Variant 158 | 159 | '@AUTHOR: ROBERT TODAR 160 | '@DIM: TWO DIM ONLY 161 | '@DEPENDINCES: IsValidConditions, ArrayGetConditions, RegExTest 162 | '@EXAMPLE: ArrayFilterTwo(TwoDimArray, "Name", "^R","ID", "\d{6}", ...) can add as many pair args as you'd like 163 | 164 | 'THIS FUNCTION IS FOR TWO DIMS ONLY 165 | If ArrayDimensionLength(SourceArray) <> 2 Then 166 | Err.Raise ARRAY_DIMENSION_INCORRECT, , "SourceArray must be a two dimensional array." 167 | End If 168 | 169 | 'SHOULD I ALWAYS RETURN HEADING?? THIS ALSO ASSUMES THERE IS A HEADING... 170 | ArrayPushTwoDim ArrayFilterTwo, ArrayExtractRow(SourceArray, LBound(SourceArray)) 171 | 172 | 'GET CONDITIONS JAGGED ARRAY. (HEADING INDEX, AND REGEX CONDITION) 173 | Dim Conditions As Variant 174 | Conditions = ArrayGetConditions(SourceArray, Args) 175 | 176 | 'CHECK CONDITIONS ON EACH ROW AFTER HEADER 177 | Dim RowIndex As Integer 178 | For RowIndex = LBound(SourceArray) + 1 To UBound(SourceArray) 179 | 180 | If IsValidConditions(SourceArray, Conditions, RowIndex) Then 181 | ArrayPushTwoDim ArrayFilterTwo, ArrayExtractRow(SourceArray, RowIndex) 182 | End If 183 | 184 | Next RowIndex 185 | 186 | End Function 187 | 188 | 'SUM A SINGLE DIM ARRAY 189 | Public Function ArraySum(ByVal SourceArray As Variant) As Double 190 | 191 | '@AUTHOR: ROBERT TODAR 192 | '@DIM: SINGLE DIM ONLY 193 | '@EXAMPLE: ArraySum (Array(5, 6, 4, 3, 2)) -> 20 194 | 195 | 'SINGLE DIM ARRAYS ONLY 196 | If ArrayDimensionLength(SourceArray) <> 1 Then 197 | Err.Raise ARRAY_DIMENSION_INCORRECT, , "SourceArray must be a 1 dimensional array." 198 | End If 199 | 200 | Dim Index As Integer 201 | For Index = LBound(SourceArray, 1) To UBound(SourceArray, 1) 202 | If Not IsNumeric(SourceArray(Index)) Then 203 | Err.Raise 55, "ArrayFunctions: ArraySum", SourceArray(Index) & vbNewLine & "^ Element in Array is not numeric" 204 | End If 205 | 206 | ArraySum = ArraySum + SourceArray(Index) 207 | Next Index 208 | 209 | End Function 210 | 211 | 'GET AVERAGE OF SINGLE DIM ARRAY 212 | Public Function ArrayAverage(ByVal SourceArray As Variant) As Double 213 | 214 | 'SINGLE DIM ARRAYS ONLY 215 | If ArrayDimensionLength(SourceArray) <> 1 Then 216 | Err.Raise ARRAY_DIMENSION_INCORRECT, , "SourceArray must be a single dimensional array." 217 | End If 218 | 219 | ArrayAverage = ArraySum(SourceArray) / ArrayLength(SourceArray) 220 | 221 | End Function 222 | 223 | 'GET LENGTH OF SINGLE DIM ARRAY, REGAURDLESS OF OPTION BASE 224 | Public Function ArrayLength(ByVal SourceArray As Variant) As Integer 225 | 226 | On Error Resume Next 'empty means 0 lenght 227 | ArrayLength = (UBound(SourceArray, 1) - LBound(SourceArray, 1)) + 1 228 | 229 | End Function 230 | 231 | 'SPREADS OUT AN ARRAY INTO A SINGLE ARRAY. EXAMPLE: JAGGED ARRAYS, dictionaries, collections. 232 | Public Function ArraySpread(ByVal SourceArray As Variant, Optional SpreadObjects As Boolean = False) As Variant 233 | 234 | 'THIS FUNCTION IS FOR SINGLE DIMS ONLY 235 | If ArrayDimensionLength(SourceArray) <> 1 Then 236 | Err.Raise ARRAY_DIMENSION_INCORRECT, , "SourceArray must be a single dimensional array." 237 | End If 238 | 239 | 'CONVERT ANY DICTIONARY OR COLLECTION INTO AN ARRAY FIRST. 240 | Dim Temp As Variant 241 | Temp = ConvertToArray(SourceArray) 242 | 243 | Dim Index As Integer 244 | For Index = LBound(Temp, 1) To UBound(Temp, 1) 245 | 246 | 'CHECK IF ELEMENT IS AN ARRAY OR OBJECT, RUN RECURSIVE IF SO ON THAT ELEMENT 247 | If IsArray(Temp(Index)) Or (IsObject(Temp(Index)) And SpreadObjects) Then 248 | 249 | 'RECURSIVE CALLS UNTIL AT BASE ELEMENTS 250 | Dim InnerTemp As Variant 251 | If SpreadObjects Then 252 | InnerTemp = ArraySpread(ConvertToArray(Temp(Index)), True) 253 | Else 254 | InnerTemp = ArraySpread(Temp(Index)) 255 | End If 256 | 257 | 'ADD EACH ELEMENT TO THE FUNCTION ARRAY 258 | Dim InnerIndex As Integer 259 | For InnerIndex = LBound(InnerTemp, 1) To UBound(InnerTemp, 1) 260 | ArrayPush ArraySpread, InnerTemp(InnerIndex) 261 | Next InnerIndex 262 | 263 | 'ELEMENT IS SINGLE ITEM, SIMPLY TO FUNCTION ARRAY 264 | Else 265 | 266 | ArrayPush ArraySpread, Temp(Index) 267 | 268 | End If 269 | 270 | Next Index 271 | 272 | End Function 273 | 274 | 'RETURNS A SINGLE DIM ARRAY OF THE INDEXES OF COLUMN HEADERS 275 | 'HEADERS NOT FOUND RETURNS EMPTY IN THAT INDEX 276 | 'EXPERIMENTAL CODE PART OF A BIGGER PLAN.... 277 | Public Function ArrayGetIndexes(ByVal SourceArray As Variant, ByVal IndexArray As Variant) As Variant 278 | 279 | Dim Temp As Variant 280 | ReDim Temp(LBound(IndexArray) To UBound(IndexArray)) 281 | 282 | Dim Index As Integer 283 | For Index = LBound(IndexArray) To UBound(IndexArray) 284 | Temp(Index) = ArrayGetColumnIndex(SourceArray, IndexArray(Index)) 285 | 286 | If Temp(Index) = -1 Then 287 | Temp(Index) = Empty 288 | End If 289 | 290 | Next Index 291 | 292 | ArrayGetIndexes = Temp 293 | 294 | End Function 295 | 296 | 'CHECK TO SEE IF SINGLE DIM ARRAY CONTAINS ANY EMPTY INDEXES 297 | Public Function ArrayContainsEmpties(ByVal SourceArray As Variant) As Boolean 298 | 299 | 'THIS FUNCTION IS FOR SINGLE DIMS ONLY 300 | If ArrayDimensionLength(SourceArray) <> 1 Then 301 | Err.Raise ARRAY_DIMENSION_INCORRECT, , "SourceArray must be a single dimensional array." 302 | End If 303 | 304 | Dim Index As Integer 305 | For Index = LBound(SourceArray, 1) To UBound(SourceArray, 1) 306 | If IsEmpty(SourceArray(Index)) Then 307 | ArrayContainsEmpties = True 308 | Exit Function 309 | End If 310 | Next Index 311 | 312 | End Function 313 | 314 | 'CHECKS TO SEE IF VALUE IS IN SINGLE DIM ARRAY. VALUE CAN BE SINGLE VALUE OR ARRAY OF VALUES. 315 | 'NEED NOTES.... 316 | Public Function ArrayContains(ByVal SourceArray As Variant, ByVal Value As Variant) As Boolean 317 | 318 | If IsArrayEmpty(SourceArray) Then 319 | Exit Function 320 | End If 321 | 322 | If IsArray(Value) Then 323 | Dim ValueIndex As Long 324 | For ValueIndex = LBound(Value) To UBound(Value) 325 | 326 | If ArrayContains(SourceArray, Value(ValueIndex)) Then 327 | ArrayContains = True 328 | Exit Function 329 | End If 330 | 331 | Next ValueIndex 332 | 333 | Exit Function 334 | End If 335 | 336 | Dim Index As Long 337 | For Index = LBound(SourceArray, 1) To UBound(SourceArray, 1) 338 | If SourceArray(Index) = Value Then 339 | ArrayContains = True 340 | Exit Function 341 | End If 342 | Next Index 343 | 344 | End Function 345 | 346 | 'CHECK TO SEE IF TWO DIM ARRAY CONTAINS HEADERS STORED IN HEADERS ARRAY 347 | Public Function ArrayContainsHeaders(ByVal SourceArray As Variant, ByVal Headers As Variant) As Variant 348 | 349 | If Not IsArray(SourceArray) Or ArrayDimensionLength(SourceArray) <> 2 Then 350 | Err.Raise 555, "SourceArray must be passed in as an two dimensional array" 351 | End If 352 | 353 | If Not IsArray(Headers) Or ArrayDimensionLength(Headers) <> 1 Then 354 | Err.Raise 555, "Headers must be passed in as a 1 dimensional array" 355 | End If 356 | 357 | Dim HeaderArray As Variant 358 | HeaderArray = ArrayExtractRow(SourceArray, LBound(SourceArray, 1)) 359 | 360 | Dim HedIndex As Integer 361 | For HedIndex = LBound(Headers, 1) To UBound(Headers, 1) 362 | 363 | If ArrayIncludes(HeaderArray, Headers(HedIndex)) = False Then 364 | Exit Function 365 | End If 366 | 367 | Next HedIndex 368 | 369 | ArrayContainsHeaders = True 370 | 371 | End Function 372 | 373 | '****************************************************************************************** 374 | ' PUBLIC FUNCTIONS 375 | '****************************************************************************************** 376 | 377 | ' Returns the length of the dimension of an array. 378 | Public Function ArrayDimensionLength(ByVal sourceArray As Variant) As Long 379 | 380 | On Error GoTo Catch 381 | Do 382 | Dim boundIndex As Long 383 | boundIndex = boundIndex + 1 384 | 385 | ' Loop until this line errors out. 386 | Dim test As Long 387 | test = UBound(sourceArray, boundIndex) 388 | Loop 389 | Catch: 390 | ' Must remove one, this gives the proper dimension length. 391 | ArrayDimensionLength = boundIndex - 1 392 | 393 | End Function 394 | 395 | 396 | 'GET A COLUMN FROM A TWO DIM ARRAY, AND RETURN A SINLGE DIM ARRAY 397 | Public Function ArrayExtractColumn(ByVal SourceArray As Variant, ByVal ColumnIndex As Integer) As Variant 398 | 399 | 'SINGLE DIM ARRAYS ONLY 400 | If ArrayDimensionLength(SourceArray) <> 2 Then 401 | Err.Raise ARRAY_DIMENSION_INCORRECT, , "SourceArray must be a two dimensional array." 402 | End If 403 | 404 | Dim Temp As Variant 405 | ReDim Temp(LBound(SourceArray, 1) To UBound(SourceArray, 1)) 406 | 407 | Dim RowIndex As Integer 408 | For RowIndex = LBound(SourceArray, 1) To UBound(SourceArray, 1) 409 | Temp(RowIndex) = SourceArray(RowIndex, ColumnIndex) 410 | Next RowIndex 411 | 412 | ArrayExtractColumn = Temp 413 | 414 | End Function 415 | 416 | 'GET A ROW FROM A TWO DIM ARRAY, AND RETURN A SINLGE DIM ARRAY 417 | Public Function ArrayExtractRow(ByVal SourceArray As Variant, ByVal RowIndex As Long) As Variant 418 | 419 | Dim Temp As Variant 420 | ReDim Temp(LBound(SourceArray, 2) To UBound(SourceArray, 2)) 421 | 422 | Dim ColIndex As Integer 423 | For ColIndex = LBound(SourceArray, 2) To UBound(SourceArray, 2) 424 | Temp(ColIndex) = SourceArray(RowIndex, ColIndex) 425 | Next ColIndex 426 | 427 | ArrayExtractRow = Temp 428 | 429 | End Function 430 | 431 | 'RETURNS A 2D ARRAY FROM A RECORDSET, OPTIONALLY INCLUDING HEADERS, AND IT TRANSPOSES TO KEEP 432 | 'ORIGINAL OPTION BASE. (TRANSPOSE WILL SET IT TO BASE 1 AUTOMATICALLY.) 433 | Public Function ArrayFromRecordset(Rs As Object, Optional IncludeHeaders As Boolean = True) As Variant 434 | 435 | '@NOTE: -Int(IncludeHeaders) RETURNS A BOOLEAN TO AN INT (0 OR 1) 436 | Dim HeadingIncrement As Integer 437 | HeadingIncrement = -Int(IncludeHeaders) 438 | 439 | 'CHECK TO MAKE SURE THERE ARE RECORDS TO PULL FROM 440 | If Rs.BOF Or Rs.EOF Then 441 | Exit Function 442 | End If 443 | 444 | 'STORE RS DATA 445 | Dim rsData As Variant 446 | rsData = Rs.GetRows 447 | 448 | 'REDIM TEMP TO ALLOW FOR HEADINGS AS WELL AS DATA 449 | Dim Temp As Variant 450 | ReDim Temp(LBound(rsData, 2) To UBound(rsData, 2) + HeadingIncrement, LBound(rsData, 1) To UBound(rsData, 1)) 451 | 452 | If IncludeHeaders = True Then 453 | 'GET HEADERS 454 | Dim headerIndex As Long 455 | For headerIndex = 0 To Rs.fields.Count - 1 456 | Temp(LBound(Temp, 1), headerIndex) = Rs.fields(headerIndex).Name 457 | Next headerIndex 458 | End If 459 | 460 | 'GET DATA 461 | Dim RowIndex As Long 462 | Dim ColIndex As Long 463 | For RowIndex = LBound(Temp, 1) + HeadingIncrement To UBound(Temp, 1) 464 | 465 | For ColIndex = LBound(Temp, 2) To UBound(Temp, 2) 466 | Temp(RowIndex, ColIndex) = rsData(ColIndex, RowIndex - HeadingIncrement) 467 | Next ColIndex 468 | 469 | Next RowIndex 470 | 471 | 'RETURN 472 | ArrayFromRecordset = Temp 473 | 474 | End Function 475 | 476 | 'LOOKS FOR VALUE IN FIRST ROW OF A TWO DIMENSIONAL ARRAY, RETURNS IT'S COLUMN INDEX 477 | Public Function ArrayGetColumnIndex(ByVal SourceArray As Variant, ByVal HeadingValue As String) As Integer 478 | 479 | Dim ColumnIndex As Integer 480 | For ColumnIndex = LBound(SourceArray, 2) To UBound(SourceArray, 2) 481 | If SourceArray(LBound(SourceArray, 1), ColumnIndex) = HeadingValue Then 482 | ArrayGetColumnIndex = ColumnIndex 483 | Exit Function 484 | End If 485 | Next ColumnIndex 486 | 487 | 'RETURN NEGATIVE IF NOT FOUND 488 | ArrayGetColumnIndex = -1 489 | 490 | End Function 491 | 492 | 'CHECKS TO SEE IF VALUE IS IN SINGLE DIM ARRAY 493 | Public Function ArrayIncludes(ByVal SourceArray As Variant, ByVal Value As Variant) As Boolean 494 | 495 | If IsArrayEmpty(SourceArray) Then 496 | Exit Function 497 | End If 498 | 499 | Dim Index As Long 500 | For Index = LBound(SourceArray, 1) To UBound(SourceArray, 1) 501 | If SourceArray(Index) = Value Then 502 | ArrayIncludes = True 503 | Exit For 504 | End If 505 | Next Index 506 | 507 | End Function 508 | 509 | 'RETURNS INDEX OF A SINGLE DIM ARRAY ELEMENT 510 | Public Function ArrayIndexOf(ByVal SourceArray As Variant, ByVal SearchElement As Variant) As Integer 511 | Dim Index As Long 512 | For Index = LBound(SourceArray, 1) To UBound(SourceArray, 1) 513 | If SourceArray(Index) = SearchElement Then 514 | ArrayIndexOf = Index 515 | Exit Function 516 | End If 517 | Next Index 518 | Index = -1 519 | End Function 520 | 521 | 'EXTRACTS LIST OF GIVEN PROPERTY. MUST BE ARRAY THAT CONTAINS DICTIONRIES AT THIS TIME. 522 | Public Function ArrayPluck(ByVal SourceArray As Variant, ByVal Key As Variant) As Variant 523 | 524 | Dim Temp As Variant 525 | ReDim Temp(LBound(SourceArray, 1) To UBound(SourceArray, 1)) 526 | 527 | Dim Index As Integer 528 | For Index = LBound(SourceArray, 1) To UBound(SourceArray, 1) 529 | Assign Temp(Index), SourceArray(Index)(Key) 530 | Next Index 531 | 532 | ArrayPluck = Temp 533 | 534 | End Function 535 | 536 | 'REMOVES LAST ELEMENT IN ARRAY, RETURNS POPPED ELEMENT 537 | Public Function ArrayPop(ByRef SourceArray As Variant) As Variant 538 | 539 | If Not IsArrayEmpty(SourceArray) Then 540 | Select Case ArrayDimensionLength(SourceArray) 541 | 542 | Case 1: 543 | ArrayPop = SourceArray(UBound(SourceArray, 1)) 544 | ReDim Preserve SourceArray(LBound(SourceArray, 1) To UBound(SourceArray, 1) - 1) 545 | 546 | Case 2: 547 | 548 | Dim Temp As Variant 549 | ReDim Temp(LBound(SourceArray, 2) To UBound(SourceArray, 2)) 550 | 551 | Dim ColIndex As Integer 552 | For ColIndex = LBound(SourceArray, 2) To UBound(SourceArray, 2) 553 | Temp(ColIndex) = SourceArray(UBound(SourceArray, 1), ColIndex) 554 | Next ColIndex 555 | ArrayPop = Temp 556 | 557 | ArrayTranspose SourceArray 558 | ReDim Preserve SourceArray(LBound(SourceArray, 1) To UBound(SourceArray, 1), LBound(SourceArray, 2) To UBound(SourceArray, 2) - 1) 559 | ArrayTranspose SourceArray 560 | 561 | End Select 562 | 563 | End If 564 | 565 | End Function 566 | 567 | ' Mutates array by adding element(s) to the end of an array. Returns the new array length. 568 | Public Function ArrayPush(ByRef sourceArray As Variant, ParamArray elements() As Variant) As Long 569 | '@author: Robert Todar 570 | '@param: must be a single dimensional array. 571 | '@param: are the elementss to be added. 572 | 573 | ' Change this if you prefer to work with option base 1 574 | Const optionBase As Long = 0 575 | 576 | Dim firstEmptyBound As Long 577 | Select Case ArrayDimensionLength(sourceArray) 578 | Case 0 579 | firstEmptyBound = optionBase 580 | ' Create space for new elements in empty array. 581 | ReDim sourceArray(optionBase To UBound(elements, 1) + optionBase) 582 | Case 1 583 | firstEmptyBound = UBound(sourceArray) + 1 584 | ' Add more space for new elements. 585 | ReDim Preserve sourceArray( _ 586 | LBound(sourceArray) To UBound(sourceArray) + UBound(elements) + 1) 587 | Case 2 588 | 'THIS SECTION IS EXPERIMENTAL... ArrayPushTwoDim IS NOT YET PROVEN. REMOVE IF DESIRED. 589 | ArrayPush = ArrayPushTwoDim(sourceArray, CVar(element)) 590 | Exit Function 591 | Case Else 592 | Err.Raise 5, "ArrayPush", "ArrayPush function only works with single dimension arrays." 593 | End Select 594 | 595 | Dim index As Long 596 | For index = LBound(elements) To UBound(elements) 597 | 598 | ' Add elements to the end of the array. Assign is to 'set' or 'let' depending on type. 599 | Assign sourceArray(firstEmptyBound), elements(index) 600 | 601 | ' Increment to the next empty index 602 | firstEmptyBound = firstEmptyBound + 1 603 | 604 | Next index 605 | 606 | ' Return new array length 607 | ArrayPush = UBound(sourceArray) + (Int(optionBase = 0) * -1) - LBound(sourceArray) 608 | 609 | End Function 610 | 611 | 'ADDS A NEW ELEMENT(S) TO AN ARRAY (AT THE END), RETURNS THE NEW ARRAY LENGTH 612 | Public Function ArrayPushTwoDim(ByRef SourceArray As Variant, ParamArray Element() As Variant) As Long 613 | 614 | Dim FirstEmptyRow As Long 615 | Dim OptionBase As Integer 616 | 617 | OptionBase = 0 618 | 619 | 'REDIM IF EMPTY, OR INCREASE ARRAY IF NOT EMPTY 620 | If IsArrayEmpty(SourceArray) Then 621 | 622 | ReDim SourceArray(OptionBase To UBound(Element, 1) + OptionBase, OptionBase To ArrayLength(Element(LBound(Element))) + OptionBase - 1) 623 | FirstEmptyRow = LBound(SourceArray, 1) 624 | 625 | Else 626 | 627 | FirstEmptyRow = UBound(SourceArray, 1) + 1 628 | SourceArray = ArrayTranspose(SourceArray) 629 | ReDim Preserve SourceArray(LBound(SourceArray, 1) To UBound(SourceArray, 1), LBound(SourceArray, 2) To UBound(SourceArray, 2) + ArrayLength(Element)) 630 | SourceArray = ArrayTranspose(SourceArray) 631 | End If 632 | 633 | 'LOOP EACH ARRAY 634 | Dim Index As Long 635 | For Index = LBound(Element, 1) To UBound(Element, 1) 636 | 637 | 638 | Dim CurrentIndex As Long 639 | CurrentIndex = LBound(Element(Index)) 640 | 641 | 'LOOP EACH ELEMENT IN CURRENT ARRAY 642 | Dim ColIndex As Long 643 | For ColIndex = LBound(SourceArray, 2) To UBound(SourceArray, 2) 644 | 645 | 'ADD ELEMENT TO THE END OF THE ARRAY. NOTE IF ERROR CHANCES ARE ARRAY DIM WAS NOT THE SAME 646 | Assign SourceArray(FirstEmptyRow, ColIndex), Element(Index)(CurrentIndex) 647 | 648 | CurrentIndex = CurrentIndex + 1 649 | 650 | Next ColIndex 651 | 652 | 'INCREMENT TO THE NEXT firstEmptyRow 653 | FirstEmptyRow = FirstEmptyRow + 1 654 | 655 | Next Index 656 | 657 | 'RETURN NEW ARRAY LENGTH 658 | ArrayPushTwoDim = UBound(SourceArray, 1) - LBound(SourceArray, 1) + 1 659 | 660 | End Function 661 | 662 | 663 | ' CREATES TEMP TEXT FILE AND SAVES ARRAY VALUES IN A CSV FORMAT, 664 | ' THEN QUERIES AND RETURNS ARRAY. 665 | Public Function ArrayQuery(SourceArray As Variant, sql As String, Optional IncludeHeaders As Boolean = True) As Variant 666 | 667 | '@USES ArrayToCSVFile 668 | '@USES ArrayFromRecordset 669 | '@RETURNS 2D ARRAY || EMPTY (IF NO RECORDS) 670 | '@PARAM {ARR} MUST BE A TWO DIMENSIONAL ARRAY, SETUP AS IF IT WERE A TABLE. 671 | '@PARAM {SQL} ADO SQL STATEMENT FOR A TEXT FILE. MUST INCLUDE 'FROM []' 672 | '@PARAM {IncludeHeaders} BOOLEAN TO RETURN HEADERS WITH DATA OR NOT 673 | '@EXAMPLE SQL = "SELECT * FROM [] WHERE [FIRSTNAME] = 'ROBERT'" 674 | 675 | 'CREATE TEMP FOLDER AND FILE NAMES 676 | Const FileName As String = "temp.txt" 677 | Dim FilePath As String 678 | FilePath = Environ("temp") 679 | 680 | 'UPDATE SQL WITH TEMP FILE NAME 681 | sql = Replace(sql, "FROM []", "FROM [" & FileName & "]") 682 | 683 | 'SEND ARRAY TO TEMP TEXTFILE IN CSV FORMAT 684 | ArrayToCSVFile SourceArray, FilePath & "\" & FileName 685 | 686 | 'CREATE CONNECTION TO TEMP FILE - CONNECTION IS SET TO COMMA SEPERATED FORMAT 687 | Dim cnn As Object 688 | Set cnn = CreateObject("ADODB.Connection") 689 | cnn.Provider = "Microsoft.Jet.OLEDB.4.0" 690 | cnn.ConnectionString = "Data Source=" & FilePath & ";" & "Extended Properties=""text;HDR=Yes;FMT=Delimited;""" 691 | cnn.Open 692 | 693 | 'CREATE RECORDSET AND QUERY ON PASSED IN SQL (QUERIES THE TEMP TEXT FILE) 694 | Dim Rs As Object 695 | Set Rs = CreateObject("ADODB.RecordSet") 696 | With Rs 697 | .ActiveConnection = cnn 698 | .Open sql 699 | 700 | 'GET AN ARRAY FROM THE RECORDSET 701 | ArrayQuery = ArrayFromRecordset(Rs, IncludeHeaders) 702 | .Close 703 | End With 704 | 705 | 'CLOSE CONNECTION AND KILL TEMP FILE 706 | cnn.Close 707 | Kill FilePath & "\" & FileName 708 | 709 | End Function 710 | 711 | 'REMOVED DUPLICATES FROM SINGLE DIM ARRAY 712 | Public Function ArrayRemoveDuplicates(SourceArray As Variant) As Variant 713 | Dim Dic As Object 714 | Dim Key As Variant 715 | 716 | If Not IsArray(SourceArray) Then 717 | SourceArray = ConvertToArray(SourceArray) 718 | End If 719 | 720 | Set Dic = CreateObject("Scripting.Dictionary") 721 | For Each Key In SourceArray 722 | Dic(Key) = 0 723 | Next 724 | ArrayRemoveDuplicates = Dic.Keys 725 | SourceArray = ArrayRemoveDuplicates 726 | End Function 727 | 728 | 'REVERSE ARRAY (CAN BE USED AFTER SORT TO GET THE DECENDING ORDER) 729 | Public Function ArrayReverse(SourceArray As Variant) As Variant 730 | 731 | Dim Temp As Variant 732 | 733 | 'REVERSE LOOP (HALF OF IT, WILL WORK FROM BOTH SIDES ON EACH ITERATION) 734 | Dim Index As Long 735 | For Index = LBound(SourceArray, 1) To ((UBound(SourceArray) + LBound(SourceArray)) \ 2) 736 | 737 | 'STORE LAST VALUE MINUS THE ITERATION 738 | Assign Temp, SourceArray(UBound(SourceArray) + LBound(SourceArray) - Index) 739 | 740 | 'SET LAST VALUE TO FIRST VALUE OF THE ARRAY 741 | Assign SourceArray(UBound(SourceArray) + LBound(SourceArray) - Index), SourceArray(Index) 742 | 743 | 'SET FIRST VALUE TO THE STORED LAST VALUE 744 | Assign SourceArray(Index), Temp 745 | 746 | Next Index 747 | 748 | ArrayReverse = SourceArray 749 | 750 | End Function 751 | 752 | 'REMOVES ELEMENT FROM ARRAY - RETURNS REMOVED ELEMENT **[SINGLE DIMENSION] 753 | Public Function ArrayShift(SourceArray As Variant, Optional ElementNumber As Long = 0) As Variant 754 | 755 | If Not IsArrayEmpty(SourceArray) Then 756 | 757 | ArrayShift = SourceArray(ElementNumber) 758 | 759 | Dim Index As Long 760 | For Index = ElementNumber To UBound(SourceArray) - 1 761 | Assign SourceArray(Index), SourceArray(Index + 1) 762 | Next Index 763 | 764 | ReDim Preserve SourceArray(UBound(SourceArray, 1) - 1) 765 | 766 | End If 767 | 768 | End Function 769 | 770 | 'SORT AN ARRAY [SINGLE DIMENSION] 771 | Public Function ArraySort(SourceArray As Variant) As Variant 772 | 773 | 'SORT ARRAY A-Z 774 | Dim OuterIndex As Long 775 | For OuterIndex = LBound(SourceArray) To UBound(SourceArray) - 1 776 | 777 | Dim InnerIndex As Long 778 | For InnerIndex = OuterIndex + 1 To UBound(SourceArray) 779 | 780 | If UCase(SourceArray(OuterIndex)) > UCase(SourceArray(InnerIndex)) Then 781 | Dim Temp As Variant 782 | Temp = SourceArray(InnerIndex) 783 | SourceArray(InnerIndex) = SourceArray(OuterIndex) 784 | SourceArray(OuterIndex) = Temp 785 | End If 786 | 787 | Next InnerIndex 788 | Next OuterIndex 789 | 790 | ArraySort = SourceArray 791 | 792 | End Function 793 | 794 | 'CHANGES THE CONTENTS OF AN ARRAY BY REMOVING OR REPLACING EXISTING ELEMENTS AND/OR ADDING NEW ELEMENTS. 795 | Public Function ArraySplice(SourceArray As Variant, Where As Long, HowManyRemoved As Integer, ParamArray Element() As Variant) As Variant 796 | 797 | 'CHECK TO SEE THAT INSERT IS NOT GREATER THAN THE Array (REDUCE IF SO) 798 | If Where > UBound(SourceArray, 1) + 1 Then 799 | Where = UBound(SourceArray, 1) + 1 800 | End If 801 | 802 | 'CHECK TO MAKE SURE REMOVED IS NOT MORE THAN THE Array (REDUCE IF SO) 803 | If HowManyRemoved > (UBound(SourceArray, 1) + 1) - Where Then 804 | HowManyRemoved = (UBound(SourceArray, 1) + 1) - Where 805 | End If 806 | 807 | If UBound(SourceArray, 1) + UBound(Element, 1) + 1 - HowManyRemoved < 0 Then 808 | ArraySplice = Empty 809 | SourceArray = Empty 810 | Exit Function 811 | End If 812 | 813 | 'SET BOUNDS TO TEMP Array 814 | Dim Temp As Variant 815 | ReDim Temp(LBound(SourceArray, 1) To UBound(SourceArray, 1) + UBound(Element, 1) + 1 - HowManyRemoved) 816 | 817 | 'LOOP TEMP Array, ADDING\REMOVING WHERE NEEDED 818 | Dim Index As Long 819 | For Index = LBound(Temp, 1) To UBound(Temp, 1) 820 | 821 | 'INSERT ONCE AT WHERE, AND ONLY VISIT ONCE 822 | Dim Visited As Boolean 823 | If Index = Where And Visited = False Then 824 | 825 | Visited = True 826 | 827 | 'ADD NEW ELEMENTS 828 | Dim Index2 As Long 829 | Dim Index3 As Long 830 | For Index2 = LBound(Element, 1) To UBound(Element, 1) 831 | Temp(Index) = Element(Index2) 832 | 833 | 'INCREMENT COUNTERS 834 | Index3 = Index3 + 1 835 | Index = Index + 1 836 | Next Index2 837 | 838 | 839 | 'GET REMOVED ELEMENTS TO RETURN 840 | Dim RemovedArray As Variant 841 | If HowManyRemoved > 0 Then 842 | ReDim RemovedArray(0 To HowManyRemoved - 1) 843 | For Index2 = LBound(RemovedArray, 1) To UBound(RemovedArray, 1) 844 | RemovedArray(Index2) = SourceArray(Where + Index2) 845 | Next Index2 846 | Else 847 | RemovedArray = Empty 848 | End If 849 | 850 | 'DECREMENT COUNTERS FOR AFTER LOOP 851 | Index = Index - 1 852 | Index3 = Index3 - HowManyRemoved 853 | 854 | Else 855 | 'ADD PREVIOUS ELEMENTS (Index3 IS A HELPER) 856 | Temp(Index) = SourceArray(Index - Index3) 857 | End If 858 | 859 | Next Index 860 | 861 | SourceArray = Temp 862 | ArraySplice = RemovedArray 863 | 864 | End Function 865 | 866 | 'BASICALY ARRAY TO STRING HOWEVER QUOTING STIRNGS, THEN SAVING TO A TEXTFILE 867 | Public Function ArrayToCSVFile(SourceArray As Variant, FilePath As String) As String 868 | 869 | Dim Temp As String 870 | Const Delimiter = "," 871 | 872 | Select Case ArrayDimensionLength(SourceArray) 873 | 'SINGLE DIMENTIONAL ARRAY 874 | Case 1 875 | Dim Index As Integer 876 | For Index = LBound(SourceArray, 1) To UBound(SourceArray, 1) 877 | 878 | If IsNumeric(SourceArray(Index)) Then 879 | Temp = Temp & SourceArray(Index) 880 | Else 881 | Temp = Temp & """" & SourceArray(Index) & """" 882 | End If 883 | Next Index 884 | 885 | 886 | '2 DIMENSIONAL ARRAY 887 | Case 2 888 | Dim RowIndex As Long 889 | Dim ColIndex As Long 890 | 891 | 'LOOP EACH ROW IN MULTI ARRAY 892 | For RowIndex = LBound(SourceArray, 1) To UBound(SourceArray, 1) 893 | 894 | 'LOOP EACH COLUMN ADDING VALUE TO STRING 895 | For ColIndex = LBound(SourceArray, 2) To UBound(SourceArray, 2) 896 | If IsNumeric(SourceArray(RowIndex, ColIndex)) Then 897 | Temp = Temp & SourceArray(RowIndex, ColIndex) 898 | Else 899 | Temp = Temp & """" & SourceArray(RowIndex, ColIndex) & """" 900 | End If 901 | 902 | If ColIndex <> UBound(SourceArray, 2) Then Temp = Temp & Delimiter 903 | Next ColIndex 904 | 905 | 'ADD NEWLINE FOR THE NEXT ROW (MINUS LAST ROW) 906 | If RowIndex <> UBound(SourceArray, 1) Then Temp = Temp & vbNewLine 907 | 908 | Next RowIndex 909 | End Select 910 | 911 | Dim Fso As Object 912 | Set Fso = CreateObject("Scripting.FileSystemObject") 913 | 914 | Dim Ts As Object 915 | Set Ts = Fso.OpenTextFile(FilePath, 2, True) '2=WRITEABLE 916 | Ts.Write Temp 917 | 918 | Set Ts = Nothing 919 | Set Fso = Nothing 920 | 921 | ArrayToCSVFile = Temp 922 | 923 | End Function 924 | 925 | 926 | 'RESIZE PASSED IN EXCEL RANGE, AND SET VALUE EQUAL TO THE ARRAY 927 | Public Sub ArrayToRange(ByVal SourceArray As Variant, Optional ByRef Target As Excel.Range) 928 | 929 | '@TODO: NEED TO TEST! ALSO THIS ASSUMES ROW, GIVE OPTION TO TRANSPOSE TO COLUMN?? 930 | 'NOTE: THIS ALWAYS FORMATS THE CELLS TO BE A STRING... REMOVE FORMATING IF NEED BE. 931 | ' THIS WAS CREATED FOR THE PURPOSE OF MAINTAINING LEADING ZEROS FOR MY ALL DATA... 932 | 933 | 'ADD WORKBOOK IF NOT 934 | Dim Wb As Workbook 935 | If Target Is Nothing Then 936 | Set Wb = Workbooks.Add 937 | Set Target = Wb.Worksheets("Sheet1").Range("A1") 938 | End If 939 | 940 | Select Case ArrayDimensionLength(SourceArray) 941 | Case 1: 942 | Set Target = Target.Resize(UBound(SourceArray) - LBound(SourceArray) + 1, 1) 943 | Target.NumberFormat = "@" 944 | Target.Value = Application.Transpose(SourceArray) 945 | 946 | Case 2: 947 | Set Target = Target.Resize((UBound(SourceArray, 1) + 1) - LBound(SourceArray, 1), (UBound(SourceArray, 2) + 1 - LBound(SourceArray, 2))) 948 | Target.NumberFormat = "@" 949 | Target.Value = SourceArray 950 | 'Target.Resize((UBound(SourceArray, 1) + 1) - LBound(SourceArray, 1), (UBound(SourceArray, 2) + 1 - LBound(SourceArray, 2))).Value = SourceArray 951 | 952 | End Select 953 | 954 | 'OPTIONAL, PLEASE REMOVE IF DESIRED... 955 | Columns.AutoFit 956 | 957 | End Sub 958 | 959 | 'RETURNS A STRING FROM A 2 DIM ARRAY, SPERATED BY OPTIONAL DELIMITER AND VBNEWLINE FOR EACH ROW 960 | Public Function ArrayToString(SourceArray As Variant, Optional Delimiter As String = ",") As String 961 | 962 | Dim Temp As String 963 | 964 | Select Case ArrayDimensionLength(SourceArray) 965 | 'SINGLE DIMENTIONAL ARRAY 966 | Case 1 967 | Temp = Join(SourceArray, Delimiter) 968 | 969 | '2 DIMENSIONAL ARRAY 970 | Case 2 971 | Dim RowIndex As Long 972 | Dim ColIndex As Long 973 | 974 | 'LOOP EACH ROW IN MULTI ARRAY 975 | For RowIndex = LBound(SourceArray, 1) To UBound(SourceArray, 1) 976 | 977 | 'LOOP EACH COLUMN ADDING VALUE TO STRING 978 | For ColIndex = LBound(SourceArray, 2) To UBound(SourceArray, 2) 979 | Temp = Temp & SourceArray(RowIndex, ColIndex) 980 | If ColIndex <> UBound(SourceArray, 2) Then Temp = Temp & Delimiter 981 | Next ColIndex 982 | 983 | 'ADD NEWLINE FOR THE NEXT ROW (MINUS LAST ROW) 984 | If RowIndex <> UBound(SourceArray, 1) Then Temp = Temp & vbNewLine 985 | 986 | Next RowIndex 987 | End Select 988 | 989 | ArrayToString = Temp 990 | 991 | End Function 992 | 993 | 'SENDS AN ARRAY TO A TEXTFILE 994 | Public Sub ArrayToTextFile(Arr As Variant, FilePath As String, Optional delimeter As String = ",") 995 | 996 | Dim Fso As Object 997 | Set Fso = CreateObject("Scripting.FileSystemObject") 998 | 999 | Dim Ts As Object 1000 | Set Ts = Fso.OpenTextFile(FilePath, 2, True) '2=WRITEABLE 1001 | Ts.Write ArrayToString(Arr, delimeter) 1002 | 1003 | Set Ts = Nothing 1004 | Set Fso = Nothing 1005 | 1006 | End Sub 1007 | 1008 | 'APPLICATION.TRANSPOSE HAS A LIMIT ON THE SIZE OF THE ARRAY, AND IS LIMITED TO THE 1ST DIM 1009 | Public Function ArrayTranspose(SourceArray As Variant) As Variant 1010 | 1011 | Dim Temp As Variant 1012 | 1013 | Select Case ArrayDimensionLength(SourceArray) 1014 | 1015 | Case 2: 1016 | 1017 | ReDim Temp(LBound(SourceArray, 2) To UBound(SourceArray, 2), LBound(SourceArray, 1) To UBound(SourceArray, 1)) 1018 | 1019 | Dim I As Long 1020 | Dim j As Long 1021 | For I = LBound(SourceArray, 2) To UBound(SourceArray, 2) 1022 | For j = LBound(SourceArray, 1) To UBound(SourceArray, 1) 1023 | Temp(I, j) = SourceArray(j, I) 1024 | Next 1025 | Next 1026 | 1027 | End Select 1028 | 1029 | ArrayTranspose = Temp 1030 | SourceArray = Temp 1031 | 1032 | End Function 1033 | 1034 | 'ADDS NEW ELEMENT TO THE BEGINING OF THE ARRAY 1035 | Public Function ArrayUnShift(SourceArray As Variant, ParamArray Element() As Variant) As Long 1036 | 1037 | 'FOR NOW THIS IS ONLY FOR SINGLE DIMENSIONS. @TODO: UPDATE TO PUSH TO MULTI DIM ARRAYS 1038 | If ArrayDimensionLength(SourceArray) <> 1 Then 1039 | ArrayUnShift = -1 1040 | Exit Function 1041 | End If 1042 | 1043 | 'RESIZE TEMP ARRAY 1044 | Dim Temp As Variant 1045 | If IsArrayEmpty(SourceArray) Then 1046 | ReDim Temp(0 To UBound(Element, 1)) 1047 | Else 1048 | ReDim Temp(UBound(SourceArray, 1) + UBound(Element, 1) + 1) 1049 | End If 1050 | 1051 | Dim Count As Long 1052 | Count = LBound(Temp, 1) 1053 | 1054 | Dim Index As Long 1055 | 1056 | 'ADD ELEMENTS TO TEMP ARRAY 1057 | For Index = LBound(Element, 1) To UBound(Element, 1) 1058 | Assign Temp(Count), Element(Index) 1059 | Count = Count + 1 1060 | Next Index 1061 | 1062 | If Not Count > UBound(Temp, 1) Then 1063 | 1064 | 'ADD ELEMENTS FROM ORIGINAL ARRAY 1065 | For Index = LBound(SourceArray, 1) To UBound(SourceArray, 1) 1066 | Assign Temp(Count), SourceArray(Index) 1067 | Count = Count + 1 1068 | Next Index 1069 | End If 1070 | 1071 | 'SET ARRAY TO TEMP ARRAY 1072 | SourceArray = Temp 1073 | 1074 | 'RETURN THE NEW LENGTH OF THE ARRAY 1075 | ArrayUnShift = UBound(SourceArray, 1) + 1 1076 | 1077 | End Function 1078 | 1079 | ' Quick tool to either set or let depending on if the element is an object 1080 | Public Function Assign(ByRef Variable As Variant, ByVal Value As Variant) As String 1081 | If IsObject(Value) Then 1082 | Set Variable = Value 1083 | Else 1084 | Let Variable = Value 1085 | End If 1086 | Assign = TypeName(Value) 1087 | End Function 1088 | 1089 | 'CONVERT OTHER LIST OBJECTS TO AN ARRAY 1090 | Public Function ConvertToArray(ByRef Val As Variant) As Variant 1091 | 1092 | Select Case TypeName(Val) 1093 | 1094 | Case "Collection": 1095 | Dim Index As Integer 1096 | For Index = 1 To Val.Count 1097 | ArrayPush ConvertToArray, Val(Index) 1098 | Next Index 1099 | 1100 | Case "Dictionary": 1101 | ConvertToArray = Val.items() 1102 | 1103 | Case Else 1104 | 1105 | If IsArray(Val) Then 1106 | ConvertToArray = Val 1107 | Else 1108 | ArrayPush ConvertToArray, Val 1109 | End If 1110 | 1111 | End Select 1112 | 1113 | End Function 1114 | 1115 | ' This function tests whether the array has actually been allocated. 1116 | Public Function IsArrayEmpty(ByRef sourceArray As Variant) As Boolean 1117 | 'a modified version of cpearsons code 1118 | 1119 | ' Array was not passed in. 1120 | If Not IsArray(sourceArray) Then 1121 | IsArrayEmpty = True 1122 | Exit Function 1123 | End If 1124 | 1125 | ' Attempt to get the UBound of the array. If the array is 1126 | ' unallocated, an error will occur. 1127 | Err.Clear 1128 | On Error Resume Next 1129 | If Not IsNumeric(UBound(sourceArray)) And (Err.Number <> 0) Then 1130 | IsArrayEmpty = True 1131 | Else 1132 | ' On rare occasion Err.Number will be 0 for an unallocated, empty array. 1133 | ' On these occasions, LBound is 0 and UBound is -1. 1134 | ' To accommodate the weird behavior, test to see if LB > UB. If so, the array is not allocated. 1135 | Err.Clear 1136 | If LBound(sourceArray) > UBound(sourceArray) Then 1137 | IsArrayEmpty = True 1138 | End If 1139 | End If 1140 | 1141 | End Function 1142 | 1143 | 1144 | '****************************************************************************************** 1145 | ' PRIVATE FUNCTIONS 1146 | '****************************************************************************************** 1147 | 1148 | 'CHECKS CURRENT ROW OF A TWO DIM ARRAY TO SEE IF CONDITIONS ARRAY PASSES 1149 | 'HELPER FUNCTION FOR ARRAYFILTERTWO 1150 | Private Function IsValidConditions(ByVal SourceArray As Variant, ByVal Conditions As Variant, ByVal RowIndex As Integer) 1151 | 1152 | 'DEPENDINCES: RegExTest 1153 | 1154 | 'CHECK CONDITIONS 1155 | Dim Index As Integer 1156 | For Index = LBound(Conditions) To UBound(Conditions) 1157 | 1158 | Dim Value As String 1159 | Value = SourceArray(RowIndex, Conditions(Index)(0)) 1160 | 1161 | Dim Pattern As String 1162 | Pattern = CStr(Conditions(Index)(1)) 1163 | 1164 | If Not RegExTest(Value, Pattern) Then 1165 | Exit Function 1166 | End If 1167 | 1168 | Next Index 1169 | 1170 | IsValidConditions = True 1171 | 1172 | End Function 1173 | 1174 | 'GROUPS HEADING INDEX WITH CONDITIONS. RETURNS JAGGED ARRAY. 1175 | 'HELPER FUNCTION FOR ARRAYFILTERTWO 1176 | Private Function ArrayGetConditions(ByVal SourceArray As Variant, ByVal Arguments As Variant) As Variant 1177 | 1178 | 'ARGUMENTS ARE PAIRED BY TWOS. (0) = COLUMN HEADING, (1) = REGEX CONDITION 1179 | Dim Index As Integer 1180 | For Index = LBound(Arguments) To UBound(Arguments) Step 2 1181 | 1182 | Dim ColumnIndex As Integer 1183 | ColumnIndex = ArrayGetColumnIndex(SourceArray, Arguments(Index)) 1184 | ArrayPush ArrayGetConditions, Array(ColumnIndex, Arguments(Index + 1)) 1185 | 1186 | Next Index 1187 | 1188 | End Function 1189 | 1190 | 'SIMPLE FUNCTION TO TEST REGULAR EXPRESSIONS. FOR HELP SEE: 1191 | Private Function RegExTest(ByVal Value As String, ByVal Pattern As String) As Boolean 1192 | 1193 | Dim RegEx As Object 1194 | Set RegEx = CreateObject("vbscript.regexp") 1195 | With RegEx 1196 | .Global = True 'TRUE MEANS IT WILL LOOK FOR ALL MATCHES, FALSE FINDS FIRST ONLY 1197 | .MultiLine = True 1198 | .IgnoreCase = True 1199 | .Pattern = Pattern 1200 | End With 1201 | 1202 | RegExTest = RegEx.TEST(Value) 1203 | 1204 | End Function 1205 | 1206 | 1207 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Robert Todar 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. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # VBA Arrays 2 | 3 | A whole bunch of Array functions to make it easier and faster coding. Many functions are to try and mimic JavaScript. Example: Push, Pop, Shift, Unshift, Splice, Sort, Reverse, length, toString. 4 | 5 | Buy Me A Coffee 6 | 7 | --- 8 | 9 | ## Other Helpful Resources 10 | 11 | - [www.roberttodar.com](https://www.roberttodar.com/) About me and my background and some of my other projects. 12 | - [Style Guide](https://github.com/todar/VBA-Style-Guide) A guide for writing clean VBA code. Notes on how to take notes =) 13 | - [Boilerplate](https://github.com/todar/VBA-Boilerplate) Boilerplate that contains a bunch of helper libraries such as JSON tools, Code Analytics, LocalStorage, Unit Testing, version control and local network distribution, userform events, and more! 14 | - [Strings](https://github.com/todar/VBA-Strings) String function library. `ToString`, `Inject`, `StringSimilarity`, and more. 15 | - [Analytics](https://github.com/todar/VBA-Analytics) Way of tracking code analytics and metrics. Useful when multiple users are running code within a shared network. 16 | - [Userform EventListener](https://github.com/todar/VBA-Userform-EventListener) Listen to events such as `mouseover`, `mouseout`, `focus`, `blur`, and more. 17 | 18 | --- 19 | 20 | ## List of Available Functions 21 | 22 | | Function Name | Description | 23 | | :----------------------- | :------------------------------------------------------------------------------------------------------------------ | 24 | | `ArrayAverage` | Returns the average of all the numbers inside an array. | 25 | | `ArrayContainsEmpties` | Returns `True` if the array contains any empties. | 26 | | `ArrayDimensionLength` | Returns the dimensionlenght of the array. | 27 | | `ArrayExtractColumn` | Extracts a column from a 2 dim array and returns it as a 1 dim array | 28 | | `ArrayExtractRow` | Extracts a row from a 2 dim array and returns it as a 1 dim array | 29 | | `ArrayFilter` | Uses regex to filter items in a single dim array | 30 | | `ArrayFilterTwo` | Uses regex to filter items in a two dim array. | 31 | | `ArrayFromRecordset` | Converts a recordset into a 2 dim array including it's headers | 32 | | `ArrayGetColumnIndex` | Return the column index based on the header name | 33 | | `ArrayGetIndexes` | Returns a single dim array of the indexes of column headers | 34 | | `ArrayIncludes` | Checks to see if a value is in single dim array | 35 | | `ArrayIndexOf` | Returns the index of an item in a single dim array | 36 | | `ArrayLength` | Returns the number of items in an array | 37 | | `ArrayPluck` | Extracts a list of a given property. Must be array of dictionries | 38 | | `ArrayPop` | Removes the last element in array, returns the popped element | 39 | | `ArrayPush` | Adds a new element(s) to an array (at the end), returns the new array length | 40 | | `ArrayPushTwoDim` | Adds a new element(s) to an array (at the end). Must be full row of data | 41 | | `ArrayQuery` | Saves array in CSV file and allows the ability to run ADODB queries on it. | 42 | | `ArrayRemoveDuplicates` | Removed duplicates from single dim array | 43 | | `ArrayReverse` | Reverse array (can be used after sort to get the descending order) | 44 | | `ArrayShift` | Removes element from array - returns removed element | 45 | | `ArraySort` | Sort an array | 46 | | `ArraySplice` | Changes the contents of an array by removing or replacing existing elements and/or adding new elements. | 47 | | `ArraySpread` | Spreads out an array into a single array. example: jagged arrays, dictionaries, collections. | 48 | | `ArraySum` | Returns the Sum of a single dim array containing numbers | 49 | | `ArrayToCSVFile` | Saves a two dim array to a CSV file | 50 | | `ArrayToString` | Returns a string from a 1 or 2 dim array, separated by optional delimiter and vbnewline for each row | 51 | | `ArrayTranspose` | Application.Transpose has a limit on the size of the array and is limited to the 1st dim. This fixes those issues. | 52 | | `ArrayUnShift` | Adds a new element to the begining of the array | 53 | | `Assign` | Quick tool to either set or let depending on if element is an object | 54 | | `ConvertToArray` | Convert other list type objects to an array | 55 | | `IsArrayEmpty` | This function tests whether the array is empty (unallocated). Returns TRUE or FALSE. | 56 | 57 | --- 58 | 59 | ## How to use 60 | 61 | 1. Import ArrayFunctions.bas file. 62 | 2. Set a reference to `Microsoft Scripting Runtime` as this uses dictionaries for removing duplicates. 63 | 64 | --- 65 | 66 | ## Examples 67 | 68 | Below are some of the examples you can do with single dim arrays. Note, there are several functions for two dim arrays as well. 69 | 70 | ```vb 71 | 'EXAMPLES OF VARIOUS FUNCTIONS 72 | Private Sub arrayFunctionExamples() 73 | ' For simplicity using `a` as the variable. Otherwise, don't do that in your real code! =) 74 | Dim a As Variant 75 | 76 | ' Single dim functions that manipulate the array. 77 | ArrayPush a, "Banana", "Apple", "Carrot" '--> Banana,Apple,Carrot 78 | ArrayPop a '--> Banana,Apple --> returns Carrot 79 | ArrayUnShift a, "Mango", "Orange" '--> Mango,Orange,Banana,Apple 80 | ArrayShift a '--> Orange,Banana,Apple 81 | ArraySplice a, 2, 0, "Coffee" '--> Orange,Banana,Coffee,Apple 82 | ArraySplice a, 0, 1, "Mango", "Coffee" '--> Mango,Coffee,Banana,Coffee,Apple 83 | ArrayRemoveDuplicates a '--> Mango,Coffee,Banana,Apple 84 | ArraySort a '--> Apple,Banana,Coffee,Mango 85 | ArrayReverse a '--> Mango,Coffee,Banana,Apple 86 | 87 | ' Array properties functions. 88 | ' These get details of the array: index of items, lenght, ect. 89 | ArrayLength a '--> 4 90 | ArrayIndexOf a, "Coffee" '--> 1 91 | ArrayIncludes a, "Banana" '--> True 92 | arrayContains a, Array("Test", "Banana") '--> True 93 | ArrayContainsEmpties a '--> False 94 | ArrayDimensionLength a '--> 1 (single dim array) 95 | IsArrayEmpty a '--> False 96 | 97 | ' Here is an example of a jagged array. 98 | a = Array(1, 2, 3, Array(4, 5, 6, Array(7, 8, 9))) 99 | 100 | ' Can flatten jagged array with the spread formula. Note this is a deep spread. 101 | ' This formula also spreads dictionaires and collections as well! 102 | a = ArraySpread(a) '--> 1,2,3,4,5,6,7,8,9 103 | 104 | ' Math function examples 105 | ArraySum a '--> 45 106 | ArrayAverage a '--> 5 107 | 108 | ' Filter use's regex pattern 109 | a = Array("Banana", "Coffee", "Apple", "Carrot", "Canolope") 110 | a = ArrayFilter(a, "^Ca|^Ap") 111 | 112 | ' Array to string works with both single and double dim arrays! 113 | Debug.Print ArrayToString(a) 114 | End Sub 115 | ``` 116 | -------------------------------------------------------------------------------- /TestModule.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "TestModule" 2 | Option Explicit 3 | 4 | 'CREATE SAMPLE TEST DATA FOR TESTING FUNCTIONS 5 | Private Sub CreateSampleData() 6 | 7 | '@Author: Robert Todar 8 | 9 | 'CHANGE FOR MORE OR LESS SAMPLE DATA 10 | Const NumberOfRows As Integer = 42 11 | 12 | 'CREATE HEADINGS 13 | Range("A1").Value = "Sample Text" 14 | Range("B1").Value = "Number" 15 | Range("C1").Value = "Dates" 16 | Range("D1").Value = "Currency" 17 | 18 | 'RANDOM DATA, FEEL FREE TO CHANGE FOR NEEDS 19 | Dim Data As Variant 20 | Data = Array("monkey", "Banana", "apple", "carrot", "cage", "elephant", "registration", "agile", "arena", "adviser", "kneel", "steward", "bake", "profession", "costume", "feedback", "begin", "carry", "exercise", "retailer", "gregarious", "rib", "seminar", "Koran") 21 | 22 | 'ADD SAMPLE DATA TO ACTIVESHEET 23 | Dim Index As Integer 24 | For Index = 1 To NumberOfRows 25 | 26 | 'ADD RANDOM TEXT FROM DATA ARRAY 27 | Range("A1").Offset(Index).Value = Data(Int((UBound(Data, 1) - 0 + 1) * Rnd + 0)) 28 | 29 | 'ADD RANDOM NUMBERS 30 | Range("b1").Offset(Index).Value = Int((50 - 0 + 1) * Rnd + 0) 31 | 32 | 'RANDOM DATES 33 | Range("c1").Offset(Index).Value = DateSerial(2017, 1, 1) + Int(Rnd * 730) 34 | 35 | 'RANDOM CURRENCY 36 | Range("D1").Offset(Index).Value = CCur(Int((50 - 0 + 1) * Rnd + 0)) 37 | 38 | Next Index 39 | 40 | Columns.AutoFit 41 | 42 | End Sub 43 | --------------------------------------------------------------------------------