Source
Arrays source
Complete extracted source for Arrays.
Read-only source snapshot. Attributes and spelling are preserved. This is an inspection listing, not a VBE import file.
1Attribute VB_Name = "Arrays"2Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"3Attribute VB_GlobalNameSpace = False4Attribute VB_Creatable = False5Attribute VB_PredeclaredId = False6Attribute VB_Exposed = False7Attribute VB_TemplateDerived = False8Attribute VB_Customizable = False9Option Explicit1011Private Const LTOTALDIMCHECK As Long = 101213Enum FilterType14 eAND = 115 eOR = 216End Enum1718Enum ResearchType19 eEqual = 100020 eNotEqual = 100121 eGreater = 100222 eGreaterOrEqual = 100323 eLess = 100424 eLessOrEqual = 100525 eTextInclude = 100626 eTextExclude = 100727End Enum2829Enum SelectionType30 eSelectLine = 231 eSelectColumn = 132End Enum3334Enum DeletionType35 eDeleteLine = 136 eDeleteColumn = 237End Enum3839Enum GroupType40 eSum = 141 eMean = 242 eCount = 343 eMin = 444 eMax = 545 eStDev = 646End Enum4748Function Exchange(ByRef val_a, ByRef val_b) As Variant49 'Swaps two values passed by reference5051 Dim vTemp As Variant52 Dim temp As Variant5354 temp = val_b55 val_b = val_a56 val_a = temp57End Function5859Function DimCounter(ByVal vArr As Variant) As Integer60 'Returns the number of dimensions in an array6162 Dim lDim As Long63 Dim lDim_checker As Long64 Dim iDim As Long6566 If Not IsArray(vArr) Then67 DimCounter = 068 Exit Function69 End If7071 For iDim = 1 To LTOTALDIMCHECK72 On Error Resume Next73 lDim_checker = UBound(vArr, iDim)74 If Err <> 0 Then75 Err.Clear76 On Error GoTo 077 DimCounter = iDim - 178 Exit Function79 End If80 Next iDim81End Function8283Function SliceArray(ByVal vArr As Variant, ByVal SelectedType As SelectionType, ByVal lIndex As Long)84 'Extracts a specified row or column from a two-dimensional array8586 Dim vArr_Out As Variant87 Dim lDimResize As Long88 Dim lSelect As Long89 Dim lCol As Long9091 If Not IsArray(vArr) Then Exit Function92 If Me.DimCounter(vArr) <> 2 Then Exit Function93 Select Case SelectedType94 Case eSelectLine95 ReDim vArr_Out(1 To 1, LBound(vArr, 2) To UBound(vArr, 2))96 For lSelect = LBound(vArr_Out, SelectedType) To UBound(vArr_Out, SelectedType)97 vArr_Out(1, lSelect) = vArr(lIndex, lSelect)98 Next lSelect99 Case eSelectColumn100 ReDim vArr_Out(LBound(vArr, SelectedType) To UBound(vArr, SelectedType), 1 To 1)101 For lSelect = LBound(vArr, SelectedType) To UBound(vArr, SelectedType)102 vArr_Out(lSelect, 1) = vArr(lSelect, lIndex)103 Next lSelect104 End Select105106 If IsArray(vArr_Out) And Not IsEmpty(vArr_Out) Then107 SliceArray = vArr_Out108 End If109End Function110111Function Transpose(ByVal vArr As Variant) As Variant112 'Transposes a two-dimensional array by swapping its rows and columns113114 Dim vArr_Out As Variant115 Dim iRow As Long116 Dim iCol As Long117118 If Not IsArray(vArr) Then Exit Function119 If Me.DimCounter(vArr) <> 2 Then Exit Function120 ReDim vArr_Out(LBound(vArr, 2) To UBound(vArr, 2), LBound(vArr, 1) To UBound(vArr, 1))121 For iRow = LBound(vArr_Out, 1) To UBound(vArr_Out, 1)122 For iCol = LBound(vArr_Out, 2) To UBound(vArr_Out, 2)123 vArr_Out(iRow, iCol) = vArr(iCol, iRow)124 Next iCol125 Next iRow126127 Transpose = vArr_Out128End Function129130Function Sort(ByVal vArr As Variant, Optional ByVal lCol As Integer = -1, Optional ByVal iSortSens As Integer = 1) As Variant131 'Sorts a one- or two-dimensional array by column using a stable merge sort132133 Dim vArr_Out As Variant134 Dim lIndex() As Long135 Dim lTemp() As Long136 Dim iDim__ As Integer137 Dim lRow As Long138 Dim lCol_Out As Long139140 iDim__ = Me.DimCounter(vArr)141142 Select Case iDim__143 Case 1144 vArr = Me.DimExpand(vArr)145 Case 2146 Case Else147 Exit Function148 End Select149150 If lCol < 0 Then lCol = LBound(vArr, 2)151 If lCol < LBound(vArr, 2) Or lCol > UBound(vArr, 2) Then Exit Function152153 If iSortSens <> 0 And iSortSens <> 1 Then154 If iDim__ = 1 Then155 ReDim vArr_Out(LBound(vArr, 1) To UBound(vArr, 1))156 For lRow = LBound(vArr, 1) To UBound(vArr, 1)157 vArr_Out(lRow) = vArr(lRow, LBound(vArr, 2))158 Next lRow159 Sort = vArr_Out160 Else161 Sort = vArr162 End If163 Exit Function164 End If165166 ReDim lIndex(LBound(vArr, 1) To UBound(vArr, 1))167 ReDim lTemp(LBound(vArr, 1) To UBound(vArr, 1))168169 For lRow = LBound(vArr, 1) To UBound(vArr, 1)170 lIndex(lRow) = lRow171 Next lRow172173 Call MergeSortRows(vArr, lIndex, lTemp, LBound(lIndex), UBound(lIndex), CLng(lCol), iSortSens)174175 If iDim__ = 1 Then176 ReDim vArr_Out(LBound(vArr, 1) To UBound(vArr, 1))177 For lRow = LBound(vArr_Out) To UBound(vArr_Out)178 vArr_Out(lRow) = vArr(lIndex(lRow), LBound(vArr, 2))179 Next lRow180 Else181 ReDim vArr_Out(LBound(vArr, 1) To UBound(vArr, 1), LBound(vArr, 2) To UBound(vArr, 2))182 For lRow = LBound(vArr_Out, 1) To UBound(vArr_Out, 1)183 For lCol_Out = LBound(vArr_Out, 2) To UBound(vArr_Out, 2)184 vArr_Out(lRow, lCol_Out) = vArr(lIndex(lRow), lCol_Out)185 Next lCol_Out186 Next lRow187 End If188189 Sort = vArr_Out190End Function191192Private Sub MergeSortRows(ByRef vArr As Variant, ByRef lIndex() As Long, ByRef lTemp() As Long, _193 ByVal lFirst As Long, ByVal lLast As Long, ByVal lCol As Long, ByVal iSortSens As Integer)194 'Recursively sorts row indices without moving the source data195196 Dim lMiddle As Long197198 If lFirst >= lLast Then Exit Sub199200 lMiddle = lFirst + (lLast - lFirst) \ 2201202 Call MergeSortRows(vArr, lIndex, lTemp, lFirst, lMiddle, lCol, iSortSens)203 Call MergeSortRows(vArr, lIndex, lTemp, lMiddle + 1, lLast, lCol, iSortSens)204 Call MergeSortedRows(vArr, lIndex, lTemp, lFirst, lMiddle, lLast, lCol, iSortSens)205End Sub206207Private Sub MergeSortedRows(ByRef vArr As Variant, ByRef lIndex() As Long, ByRef lTemp() As Long, _208 ByVal lFirst As Long, ByVal lMiddle As Long, ByVal lLast As Long, _209 ByVal lCol As Long, ByVal iSortSens As Integer)210 'Merges sorted row indices while preserving the original order of equal values211212 Dim lLeft As Long213 Dim lRight As Long214 Dim lOut As Long215 Dim bUseRight As Boolean216217 lLeft = lFirst218 lRight = lMiddle + 1219 lOut = lFirst220221 Do While lLeft <= lMiddle And lRight <= lLast222 If iSortSens = 1 Then223 bUseRight = (vArr(lIndex(lLeft), lCol) > vArr(lIndex(lRight), lCol))224 Else225 bUseRight = (vArr(lIndex(lLeft), lCol) < vArr(lIndex(lRight), lCol))226 End If227228 If bUseRight Then229 lTemp(lOut) = lIndex(lRight)230 lRight = lRight + 1231 Else232 lTemp(lOut) = lIndex(lLeft)233 lLeft = lLeft + 1234 End If235 lOut = lOut + 1236 Loop237238 Do While lLeft <= lMiddle239 lTemp(lOut) = lIndex(lLeft)240 lLeft = lLeft + 1241 lOut = lOut + 1242 Loop243244 Do While lRight <= lLast245 lTemp(lOut) = lIndex(lRight)246 lRight = lRight + 1247 lOut = lOut + 1248 Loop249250 For lOut = lFirst To lLast251 lIndex(lOut) = lTemp(lOut)252 Next lOut253End Sub254255256Function DimReduce(ByVal vArr As Variant) As Variant257 'Converts a single-row or single-column 2D array into a 1D array258259 Dim vArr_Out As Variant260 Dim lRow As Long261 Dim lCol As Long262263 If Not IsArray(vArr) Then Exit Function264 If Me.DimCounter(vArr) <> 2 Then Exit Function265266 If LBound(vArr, 1) = UBound(vArr, 1) Then267 ReDim vArr_Out(LBound(vArr, 2) To UBound(vArr, 2))268 For lCol = LBound(vArr, 2) To UBound(vArr, 2)269 vArr_Out(lCol) = vArr(LBound(vArr, 1), lCol)270 Next lCol271 ElseIf LBound(vArr, 2) = UBound(vArr, 2) Then272 ReDim vArr_Out(LBound(vArr, 1) To UBound(vArr, 1))273 For lRow = LBound(vArr, 1) To UBound(vArr, 1)274 vArr_Out(lRow) = vArr(lRow, LBound(vArr, 2))275 Next lRow276 Else277 Exit Function278 End If279280 DimReduce = vArr_Out281End Function282283Function DimExpand(ByVal vArr As Variant) As Variant284 'Converts a one-dimensional array into a two-dimensional column array285286 Dim vArr_Out As Variant287 Dim iRow As Long288 Dim iCol As Long289 Dim iDim As Long290291 If Not IsArray(vArr) Then Exit Function292 If Me.DimCounter(vArr) <> 1 Then Exit Function293 ReDim vArr_Out(LBound(vArr, 1) To UBound(vArr, 1), 1 To 1)294 iCol = UBound(vArr, 1)295 For iRow = LBound(vArr_Out, 1) To UBound(vArr_Out, 1)296 vArr_Out(iRow, 1) = vArr(iRow)297 Next iRow298299 If IsArray(vArr_Out) Then300 DimExpand = vArr_Out301 End If302End Function303304Function DimSplit(ByVal vArr As Variant) As Variant305 'Converts a two-dimensional array into a one-dimensional array of row arrays306307 Dim vArr_Template As Variant308 Dim lRow As Long309 Dim lCol As Long310 Dim vArr_Out As Variant311312 If Not IsArray(vArr) Then Exit Function313 If Me.DimCounter(vArr) <> 2 Then Exit Function314 ReDim vArr_Out(LBound(vArr, 1) To UBound(vArr, 1))315 ReDim vArr_Template(LBound(vArr, 2) To UBound(vArr, 2))316 For lRow = LBound(vArr_Out) To UBound(vArr_Out)317 vArr_Out(lRow) = vArr_Template318 For lCol = LBound(vArr, 2) To UBound(vArr, 2)319 vArr_Out(lRow)(lCol) = vArr(lRow, lCol)320 Next lCol321 Next lRow322323 If IsArray(vArr_Out) Then324 DimSplit = vArr_Out325 End If326End Function327328Function DimMerge(ByVal vArr As Variant) As Variant329 'Converts an array of row arrays into a two-dimensional array330331 Dim vArr_Out As Variant332 Dim lRow As Long333 Dim lCol As Long334335 If Not IsArray(vArr) Then Exit Function336 If Me.DimCounter(vArr) <> 1 Then Exit Function337 If Not IsArray(vArr(LBound(vArr))) Then Exit Function338 If Me.DimCounter(vArr(LBound(vArr))) <> 1 Then Exit Function339 ReDim vArr_Out(LBound(vArr) To UBound(vArr), LBound(vArr(LBound(vArr))) To UBound(vArr(LBound(vArr))))340 For lRow = LBound(vArr_Out, 1) To UBound(vArr_Out, 1)341 For lCol = LBound(vArr_Out, 2) To UBound(vArr_Out, 2)342 vArr_Out(lRow, lCol) = vArr(lRow)(lCol)343 Next lCol344 Next lRow345346 If IsArray(vArr_Out) Then347 DimMerge = vArr_Out348 End If349End Function350351Function Filter(ByVal vArr As Variant, _352 ByVal lFilterColumn1 As Long, ByVal ResearchType1 As ResearchType, ByVal vComparedValues1 As Variant, Optional ByVal IncludeBlank As Boolean = False, _353 Optional ByVal FilterType As FilterType = eAND, _354 Optional ByVal lFilterColumn2 As Long = -1, Optional ByVal ResearchType2 As ResearchType = eEqual, Optional ByVal vComparedValues2 As Variant = Empty) As Variant355 'Filters an array using up to two criteria with a single output allocation356357 Dim vArr_Out As Variant358 Dim vCriterionArray1 As Variant359 Dim vCriterionArray2 As Variant360 Dim lSelectedRows() As Long361 Dim lRow As Long362 Dim lCol As Long363 Dim lCount As Long364 Dim lOut As Long365 Dim bCase1 As Boolean366 Dim bCaseTotal As Boolean367 Dim bArray2_Empty As Boolean368 Dim vValue As Variant369370 If Not IsArray(vArr) Then Exit Function371 If IsEmpty(vComparedValues1) Then372 Debug.Print ("No filter applied")373 Filter = vArr374 Exit Function375 End If376377 Select Case FilterType378 Case eAND, eOR379 Case Else380 Exit Function381 End Select382383 Select Case Me.DimCounter(vArr)384 Case 1385 vArr = Me.DimExpand(vArr)386 Case 2387 Case Else388 Exit Function389 End Select390391 If lFilterColumn1 < LBound(vArr, 2) Or lFilterColumn1 > UBound(vArr, 2) Then Exit Function392393 bArray2_Empty = IsEmpty(vComparedValues2)394 If Not bArray2_Empty Then395 If lFilterColumn2 < LBound(vArr, 2) Or lFilterColumn2 > UBound(vArr, 2) Then Exit Function396 End If397398 vCriterionArray1 = BuildCriterionArray(lFilterColumn1, vComparedValues1)399 If Not bArray2_Empty Then vCriterionArray2 = BuildCriterionArray(lFilterColumn2, vComparedValues2)400401 ReDim lSelectedRows(1 To UBound(vArr, 1) - LBound(vArr, 1) + 1)402403 For lRow = LBound(vArr, 1) To UBound(vArr, 1)404 vValue = vArr(lRow, lFilterColumn1)405 If IsError(vValue) Or IsNull(vValue) Then406 bCase1 = False407 Else408 bCase1 = CheckCriterion(vValue, ResearchType1, vCriterionArray1, IncludeBlank)409 End If410411 If bArray2_Empty Then412 bCaseTotal = bCase1413 ElseIf FilterType = eAND Then414 bCaseTotal = False415 If bCase1 Then416 vValue = vArr(lRow, lFilterColumn2)417 If Not IsError(vValue) And Not IsNull(vValue) Then418 bCaseTotal = CheckCriterion(vValue, ResearchType2, vCriterionArray2, IncludeBlank)419 End If420 End If421 Else422 bCaseTotal = True423 If Not bCase1 Then424 vValue = vArr(lRow, lFilterColumn2)425 If IsError(vValue) Or IsNull(vValue) Then426 bCaseTotal = False427 Else428 bCaseTotal = CheckCriterion(vValue, ResearchType2, vCriterionArray2, IncludeBlank)429 End If430 End If431 End If432433 If bCaseTotal Then434 lCount = lCount + 1435 lSelectedRows(lCount) = lRow436 End If437 Next lRow438439 If lCount = 0 Then Exit Function440441 ReDim vArr_Out(1 To lCount, LBound(vArr, 2) To UBound(vArr, 2))442443 For lOut = 1 To lCount444 For lCol = LBound(vArr, 2) To UBound(vArr, 2)445 vArr_Out(lOut, lCol) = vArr(lSelectedRows(lOut), lCol)446 Next lCol447 Next lOut448449 Filter = vArr_Out450End Function451452Private Function BuildCriterionArray(ByVal lColumn As Long, vArr As Variant) As Variant453 'Converts a single criterion or column/row vector to a one-dimensional array454455 Dim vArr_Out As Variant456457 If IsArray(vArr) Then458 Select Case Me.DimCounter(vArr)459 Case 1460 BuildCriterionArray = vArr461 Case 2462 BuildCriterionArray = Me.DimReduce(vArr)463 End Select464 Else465 ReDim vArr_Out(1 To 1)466 vArr_Out(1) = vArr467 BuildCriterionArray = vArr_Out468 End If469End Function470471Private Function CheckCriterion(vComparedValue As Variant, ResearchType As ResearchType, vCriterionArray As Variant, ByVal IncludeBlank As Boolean) As Variant472 'Checks whether a value satisfies a criterion, including inverse comparisons473474 Dim bInvert As Boolean475 Dim vCriterionValue As Variant476 Dim bCase As Boolean477 Dim lRow As Long478479 If IsError(vComparedValue) Or IsNull(vComparedValue) Then Exit Function480 If Not IsArray(vCriterionArray) Then481 CheckCriterion = True482 Exit Function483 End If484485 Select Case ResearchType486 Case eEqual, eLess, eGreater, eTextInclude487 bInvert = False488 Case Else489 bInvert = True490 End Select491492 If Not IncludeBlank Then493 If IsEmpty(vComparedValue) Then494 CheckCriterion = bInvert495 Exit Function496 End If497 End If498499 For lRow = LBound(vCriterionArray) To UBound(vCriterionArray)500 vCriterionValue = vCriterionArray(lRow)501 If IsError(vCriterionValue) Or IsNull(vCriterionValue) Then GoTo NextCriterion502503 Select Case ResearchType504 Case eEqual, eNotEqual505 If IsNumeric(vComparedValue) And Len(vComparedValue) > 0 And IsNumeric(vCriterionValue) Then506 If CDbl(vComparedValue) = CDbl(vCriterionValue) Then507 bCase = True508 Exit For509 End If510 Else511 If UCase(CStr(vComparedValue)) = UCase(CStr(vCriterionValue)) Then512 bCase = True513 Exit For514 End If515 End If516517 Case eLess, eGreaterOrEqual518 If IsNumeric(vComparedValue) And Len(vComparedValue) > 0 And IsNumeric(vCriterionValue) Then519 If CDbl(vComparedValue) < CDbl(vCriterionValue) Then520 bCase = True521 Exit For522 End If523 Else524 If UCase(CStr(vComparedValue)) < UCase(CStr(vCriterionValue)) Then525 bCase = True526 Exit For527 End If528 End If529530 Case eGreater, eLessOrEqual531 If IsNumeric(vComparedValue) And Len(vComparedValue) > 0 And IsNumeric(vCriterionValue) Then532 If CDbl(vComparedValue) > CDbl(vCriterionValue) Then533 bCase = True534 Exit For535 End If536 Else537 If UCase(CStr(vComparedValue)) > UCase(CStr(vCriterionValue)) Then538 bCase = True539 Exit For540 End If541 End If542543 Case eTextInclude, eTextExclude544 If InStr(1, CStr(vComparedValue), CStr(vCriterionValue), vbBinaryCompare) Then545 bCase = True546 Exit For547 End If548 End Select549NextCriterion:550 Next lRow551552 If bInvert Then bCase = Not bCase553 CheckCriterion = bCase554End Function555556557558Function Unique(ByVal vArr As Variant) As Variant559 'Returns the unique values from a column vector in first-appearance order560561 Dim oDict As New Dictionary562 Dim vArr_Out As Variant563 Dim vKeys() As Variant564 Dim vKey As Variant565 Dim lRow As Long566 Dim lCol As Long567 Dim lCount As Long568 Dim bBlank As Boolean569 Dim bNull As Boolean570571 If Not IsArray(vArr) Then Exit Function572 If Me.DimCounter(vArr) = 1 Then vArr = Me.DimExpand(vArr)573 If Me.DimCounter(vArr) <> 2 Then Exit Function574575 lCol = LBound(vArr, 2)576 ReDim vKeys(1 To UBound(vArr, 1) - LBound(vArr, 1) + 1)577 oDict.CompareMode = vbBinaryCompare578579 For lRow = LBound(vArr, 1) To UBound(vArr, 1)580 vKey = vArr(lRow, lCol)581 If IsError(vKey) Then582 'Excel errors are skipped because they cannot be dictionary keys583 ElseIf IsNull(vKey) Then584 If Not bNull Then585 lCount = lCount + 1586 vKeys(lCount) = Null587 bNull = True588 End If589 ElseIf IsEmpty(vKey) Then590 If Not bBlank Then591 lCount = lCount + 1592 vKeys(lCount) = Empty593 bBlank = True594 End If595 ElseIf Not oDict.Exists(vKey) Then596 lCount = lCount + 1597 oDict.Add vKey, lCount598 vKeys(lCount) = vKey599 End If600 Next lRow601602 If lCount = 0 Then Exit Function603604 ReDim vArr_Out(1 To lCount, 1 To 1)605 For lRow = 1 To lCount606 vArr_Out(lRow, 1) = vKeys(lRow)607 Next lRow608609 Unique = vArr_Out610End Function611Function InsertColumns(ByVal vArr As Variant, ByVal vColumns As Variant, Optional ByVal bRedim As Boolean = True) As Variant612 'Appends columns to a 2D array or overwrites its last columns when bRedim is False613614 Dim vArr_Out As Variant615 Dim lRow As Long616 Dim lCol As Long617 Dim lRowSource As Long618 Dim lColSource As Long619 Dim lStart As Long620 Dim lNumColumns As Long621 Dim iDim As Integer622623 If Not IsArray(vArr) Or Not IsArray(vColumns) Then Exit Function624 If Me.DimCounter(vArr) <> 2 Then Exit Function625626 iDim = Me.DimCounter(vColumns)627 If iDim <> 1 And iDim <> 2 Then Exit Function628629 If iDim = 1 Then630 If UBound(vColumns) - LBound(vColumns) <> UBound(vArr, 1) - LBound(vArr, 1) Then Exit Function631 lNumColumns = 1632 Else633 If UBound(vColumns, 1) - LBound(vColumns, 1) <> UBound(vArr, 1) - LBound(vArr, 1) Then Exit Function634 lNumColumns = UBound(vColumns, 2) - LBound(vColumns, 2) + 1635 End If636637 If Not bRedim Then638 If lNumColumns > UBound(vArr, 2) - LBound(vArr, 2) + 1 Then Exit Function639 End If640641 If bRedim Then642 ReDim vArr_Out(LBound(vArr, 1) To UBound(vArr, 1), LBound(vArr, 2) To UBound(vArr, 2) + lNumColumns)643 Else644 ReDim vArr_Out(LBound(vArr, 1) To UBound(vArr, 1), LBound(vArr, 2) To UBound(vArr, 2))645 End If646647 For lRow = LBound(vArr, 1) To UBound(vArr, 1)648 For lCol = LBound(vArr, 2) To UBound(vArr, 2)649 vArr_Out(lRow, lCol) = vArr(lRow, lCol)650 Next lCol651 Next lRow652653 lStart = UBound(vArr_Out, 2) - lNumColumns + 1654655 For lRow = LBound(vArr_Out, 1) To UBound(vArr_Out, 1)656 lRowSource = lRow - LBound(vArr, 1)657 For lCol = lStart To UBound(vArr_Out, 2)658 If iDim = 1 Then659 vArr_Out(lRow, lCol) = vColumns(LBound(vColumns) + lRowSource)660 Else661 lColSource = LBound(vColumns, 2) + lCol - lStart662 vArr_Out(lRow, lCol) = vColumns(LBound(vColumns, 1) + lRowSource, lColSource)663 End If664 Next lCol665 Next lRow666667 InsertColumns = vArr_Out668End Function669670Function InsertLines(ByVal vArr As Variant, ByVal vLines As Variant, Optional ByVal bRedim As Boolean = True) As Variant671 'Appends rows to a 2D array or overwrites its last rows when bRedim is False672673 Dim vArr_Out As Variant674 Dim lRow As Long675 Dim lCol As Long676 Dim lRowSource As Long677 Dim lColSource As Long678 Dim lStart As Long679 Dim lNumLines As Long680 Dim lFirstRow As Long681 Dim lLastRow As Long682 Dim lFirstCol As Long683 Dim lLastCol As Long684 Dim iDim As Integer685 Dim iLinesDim As Integer686687 If Not IsArray(vLines) Then688 InsertLines = vArr689 Exit Function690 End If691692 If Not IsArray(vArr) Then693 InsertLines = vLines694 Exit Function695 End If696697 iDim = Me.DimCounter(vArr)698 iLinesDim = Me.DimCounter(vLines)699 If iDim <> 1 And iDim <> 2 Then Exit Function700 If iLinesDim <> 1 And iLinesDim <> 2 Then Exit Function701702 If iDim = 1 Then703 lFirstRow = 1704 lLastRow = 1705 lFirstCol = LBound(vArr)706 lLastCol = UBound(vArr)707 Else708 lFirstRow = LBound(vArr, 1)709 lLastRow = UBound(vArr, 1)710 lFirstCol = LBound(vArr, 2)711 lLastCol = UBound(vArr, 2)712 End If713714 If iLinesDim = 1 Then715 If UBound(vLines) - LBound(vLines) <> lLastCol - lFirstCol Then Exit Function716 lNumLines = 1717 Else718 If UBound(vLines, 2) - LBound(vLines, 2) <> lLastCol - lFirstCol Then Exit Function719 lNumLines = UBound(vLines, 1) - LBound(vLines, 1) + 1720 End If721722 If Not bRedim Then723 If lNumLines > lLastRow - lFirstRow + 1 Then Exit Function724 End If725726 If bRedim Then727 ReDim vArr_Out(lFirstRow To lLastRow + lNumLines, lFirstCol To lLastCol)728 Else729 ReDim vArr_Out(lFirstRow To lLastRow, lFirstCol To lLastCol)730 End If731732 For lRow = lFirstRow To lLastRow733 For lCol = lFirstCol To lLastCol734 If iDim = 1 Then735 vArr_Out(lRow, lCol) = vArr(lCol)736 Else737 vArr_Out(lRow, lCol) = vArr(lRow, lCol)738 End If739 Next lCol740 Next lRow741742 lStart = UBound(vArr_Out, 1) - lNumLines + 1743744 For lRow = lStart To UBound(vArr_Out, 1)745 lRowSource = lRow - lStart746 For lCol = lFirstCol To lLastCol747 If iLinesDim = 1 Then748 vArr_Out(lRow, lCol) = vLines(LBound(vLines) + lCol - lFirstCol)749 Else750 lColSource = LBound(vLines, 2) + lCol - lFirstCol751 vArr_Out(lRow, lCol) = vLines(LBound(vLines, 1) + lRowSource, lColSource)752 End If753 Next lCol754 Next lRow755756 InsertLines = vArr_Out757End Function758759Function DeleteElement(ByVal vArr As Variant, ByVal lIndexDel As Long, ByVal eDeletionType As DeletionType) As Variant760 'Removes one row or column while preserving the other dimension and its bounds761762 Dim vArr_Out As Variant763 Dim lRow As Long764 Dim lCol As Long765 Dim lRowSource As Long766 Dim lColSource As Long767768 If Not IsArray(vArr) Then Exit Function769 If Me.DimCounter(vArr) <> 2 Then Exit Function770771 Select Case eDeletionType772 Case eDeleteLine773 If lIndexDel < LBound(vArr, 1) Or lIndexDel > UBound(vArr, 1) Then774 DeleteElement = vArr775 Exit Function776 End If777 If LBound(vArr, 1) = UBound(vArr, 1) Then Exit Function778 ReDim vArr_Out(LBound(vArr, 1) To UBound(vArr, 1) - 1, LBound(vArr, 2) To UBound(vArr, 2))779780 Case eDeleteColumn781 If lIndexDel < LBound(vArr, 2) Or lIndexDel > UBound(vArr, 2) Then782 DeleteElement = vArr783 Exit Function784 End If785 If LBound(vArr, 2) = UBound(vArr, 2) Then Exit Function786 ReDim vArr_Out(LBound(vArr, 1) To UBound(vArr, 1), LBound(vArr, 2) To UBound(vArr, 2) - 1)787788 Case Else789 Exit Function790 End Select791792 For lRow = LBound(vArr_Out, 1) To UBound(vArr_Out, 1)793 lRowSource = lRow794 If eDeletionType = eDeleteLine And lRow >= lIndexDel Then lRowSource = lRow + 1795796 For lCol = LBound(vArr_Out, 2) To UBound(vArr_Out, 2)797 lColSource = lCol798 If eDeletionType = eDeleteColumn And lCol >= lIndexDel Then lColSource = lCol + 1799 vArr_Out(lRow, lCol) = vArr(lRowSource, lColSource)800 Next lCol801 Next lRow802803 DeleteElement = vArr_Out804End Function805806807Function FillColumn(ByVal vArr As Variant, ByVal vColumn As Variant, ByVal lIndex As Long) As Variant808 'Fills a specified column using a 1D or 2D column vector809810 Dim vArr_Out As Variant811 Dim lRow As Long812 Dim lCol As Long813 Dim lSourceRow As Long814 Dim lSourceCol As Long815816 If Not IsArray(vArr) Or Not IsArray(vColumn) Then Exit Function817 If Me.DimCounter(vArr) = 1 Then vArr = Me.DimExpand(vArr)818 If Me.DimCounter(vArr) <> 2 Then Exit Function819 If Me.DimCounter(vColumn) = 1 Then vColumn = Me.DimExpand(vColumn)820 If Me.DimCounter(vColumn) <> 2 Then Exit Function821822 If lIndex < LBound(vArr, 2) Or lIndex > UBound(vArr, 2) Then Exit Function823 If LBound(vColumn, 2) <> UBound(vColumn, 2) Then Exit Function824 If UBound(vColumn, 1) - LBound(vColumn, 1) <> UBound(vArr, 1) - LBound(vArr, 1) Then Exit Function825826 ReDim vArr_Out(LBound(vArr, 1) To UBound(vArr, 1), LBound(vArr, 2) To UBound(vArr, 2))827 lSourceCol = LBound(vColumn, 2)828829 For lRow = LBound(vArr, 1) To UBound(vArr, 1)830 lSourceRow = LBound(vColumn, 1) + lRow - LBound(vArr, 1)831 For lCol = LBound(vArr, 2) To UBound(vArr, 2)832 If lCol = lIndex Then833 vArr_Out(lRow, lCol) = vColumn(lSourceRow, lSourceCol)834 Else835 vArr_Out(lRow, lCol) = vArr(lRow, lCol)836 End If837 Next lCol838 Next lRow839840 FillColumn = vArr_Out841End Function842843Function Change_Lbound(ByVal vArr As Variant, ByVal lLbound As Long, ByVal lDim As Long) As Variant844 'Changes the lower bound of a selected dimension without changing its values845846 Dim vArr_Out As Variant847 Dim lRow As Long848 Dim lCol As Long849 Dim lRowSource As Long850 Dim lColSource As Long851 Dim lLast As Long852 Dim iDim As Integer853854 If Not IsArray(vArr) Then Exit Function855 iDim = Me.DimCounter(vArr)856857 If iDim = 1 Then858 If lDim <> 1 Then Exit Function859 lLast = lLbound + UBound(vArr) - LBound(vArr)860 ReDim vArr_Out(lLbound To lLast)861 For lRow = lLbound To lLast862 vArr_Out(lRow) = vArr(LBound(vArr) + lRow - lLbound)863 Next lRow864 ElseIf iDim = 2 Then865 Select Case lDim866 Case 1867 lLast = lLbound + UBound(vArr, 1) - LBound(vArr, 1)868 ReDim vArr_Out(lLbound To lLast, LBound(vArr, 2) To UBound(vArr, 2))869 Case 2870 lLast = lLbound + UBound(vArr, 2) - LBound(vArr, 2)871 ReDim vArr_Out(LBound(vArr, 1) To UBound(vArr, 1), lLbound To lLast)872 Case Else873 Exit Function874 End Select875876 For lRow = LBound(vArr_Out, 1) To UBound(vArr_Out, 1)877 lRowSource = LBound(vArr, 1) + lRow - LBound(vArr_Out, 1)878 For lCol = LBound(vArr_Out, 2) To UBound(vArr_Out, 2)879 lColSource = LBound(vArr, 2) + lCol - LBound(vArr_Out, 2)880 vArr_Out(lRow, lCol) = vArr(lRowSource, lColSource)881 Next lCol882 Next lRow883 Else884 Exit Function885 End If886887 Change_Lbound = vArr_Out888End Function889890Function GroupBy(ByVal vArr As Variant, ByVal lIndexKey As Long, ByVal lIndexGroup As Long, ByVal eGroupType As GroupType) As Variant891 'Groups a two-dimensional array and calculates one statistic per key in a single pass892893 Dim oDictKey As New Dictionary894 Dim vArr_Out As Variant895 Dim vKeys() As Variant896 Dim vStats() As Double897 Dim vKey As Variant898 Dim vValue As Variant899 Dim lRow As Long900 Dim lGroup As Long901 Dim lCount As Long902 Dim lBlank As Long903 Dim lRows As Long904 Dim dblValue As Double905 Dim dblDelta As Double906 Dim dblVariance As Double907908 If Not IsArray(vArr) Then909 Debug.Print ("Error GroupBy -> vArr is not an array")910 GroupBy = vArr911 Exit Function912 End If913914 If Me.DimCounter(vArr) <> 2 Then915 Debug.Print ("Error GroupBy -> vArr must have two dimensions")916 GroupBy = vArr917 Exit Function918 End If919920 If lIndexKey < LBound(vArr, 2) Or lIndexKey > UBound(vArr, 2) Then Exit Function921 If lIndexGroup < LBound(vArr, 2) Or lIndexGroup > UBound(vArr, 2) Then Exit Function922923 Select Case eGroupType924 Case eSum, eMean, eCount, eMin, eMax, eStDev925 Case Else926 Exit Function927 End Select928929 lRows = UBound(vArr, 1) - LBound(vArr, 1) + 1930 ReDim vKeys(1 To lRows)931 ReDim vStats(1 To lRows, 1 To 3)932 oDictKey.CompareMode = vbBinaryCompare933934 For lRow = LBound(vArr, 1) To UBound(vArr, 1)935 vKey = vArr(lRow, lIndexKey)936937 If IsError(vKey) Then938 Debug.Print ("Error GroupBy -> error value in grouping column")939 Exit Function940 End If941 If IsNull(vKey) Then942 Debug.Print ("Error GroupBy -> Null key")943 Exit Function944 End If945946 If IsEmpty(vKey) Then947 If lBlank = 0 Then948 lCount = lCount + 1949 lBlank = lCount950 vKeys(lCount) = vKey951 End If952 lGroup = lBlank953 Else954 If Not oDictKey.Exists(vKey) Then955 lCount = lCount + 1956 oDictKey.Add vKey, lCount957 vKeys(lCount) = vKey958 End If959 lGroup = oDictKey(vKey)960 End If961962 vValue = vArr(lRow, lIndexGroup)963 If Not IsError(vValue) Then964 If Not IsNull(vValue) Then965 If eGroupType = eCount Then966 If Not IsEmpty(vValue) Then967 If Len(CStr(vValue)) > 0 Then vStats(lGroup, 1) = vStats(lGroup, 1) + 1968 End If969 ElseIf Not IsEmpty(vValue) And IsNumeric(vValue) Then970 dblValue = CDbl(vValue)971 Select Case eGroupType972 Case eSum973 vStats(lGroup, 2) = vStats(lGroup, 2) + dblValue974 Case eMean, eStDev975 vStats(lGroup, 1) = vStats(lGroup, 1) + 1976 dblDelta = dblValue - vStats(lGroup, 2)977 vStats(lGroup, 2) = vStats(lGroup, 2) + dblDelta / vStats(lGroup, 1)978 If eGroupType = eStDev Then979 vStats(lGroup, 3) = vStats(lGroup, 3) + dblDelta * (dblValue - vStats(lGroup, 2))980 End If981 Case eMin982 If vStats(lGroup, 1) = 0 Then983 vStats(lGroup, 2) = dblValue984 ElseIf dblValue < vStats(lGroup, 2) Then985 vStats(lGroup, 2) = dblValue986 End If987 vStats(lGroup, 1) = vStats(lGroup, 1) + 1988 Case eMax989 If vStats(lGroup, 1) = 0 Then990 vStats(lGroup, 2) = dblValue991 ElseIf dblValue > vStats(lGroup, 2) Then992 vStats(lGroup, 2) = dblValue993 End If994 vStats(lGroup, 1) = vStats(lGroup, 1) + 1995 End Select996 End If997 End If998 End If999 Next lRow10001001 ReDim vArr_Out(1 To lCount, 1 To 2)10021003 For lRow = 1 To lCount1004 vArr_Out(lRow, 1) = vKeys(lRow)1005 Select Case eGroupType1006 Case eCount1007 vArr_Out(lRow, 2) = vStats(lRow, 1)1008 Case eStDev1009 If vStats(lRow, 1) > 0 Then1010 dblVariance = vStats(lRow, 3) / vStats(lRow, 1)1011 If dblVariance < 0 Then dblVariance = 01012 vArr_Out(lRow, 2) = Sqr(dblVariance)1013 Else1014 vArr_Out(lRow, 2) = 0#1015 End If1016 Case Else1017 vArr_Out(lRow, 2) = vStats(lRow, 2)1018 End Select1019 Next lRow10201021 GroupBy = vArr_Out1022End Function1023102410251026