2
\$\begingroup\$

I'm back with improved version of previous Deca dimensional array sort function. This one is not just 10 dimension limited. It could be extended to unlimited number of dimensions by simply adding rows using same logic under each Select case iteration. A limit still exists, which is it's the memory limit.

Compared with previous code, there are a number of advantages:

  1. A number of complementary functions within the same function, extendable with other functions without the need to repeat code (fillZero, fillSequence, clearArray, etc).

  2. Helper functions could be used independently for building various other functions.

  3. This function is considerably shorter then previous one.

Does anyone have any improvement ideas? The next step will be adding a filter array function.

Option Explicit

Public Function SortArray(ByRef arr As Variant, ByVal selPoint As Variant, ByRef selDim As Integer, Optional ByRef ascend As Boolean = True) As Variant
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Multi Dimensional Ascending and Descending Sort Array Function
'Inputs:
'1) arr         = one to 10 dimensional symmetrical array
'2) selPoint    = selected point index as string e.g. "arr(1,15,4)" or just "(1,15,4)"
'3) selDim      = selected dimension, integer from 1 to 10
'4) ascend      = Optional ascending or descending direction (default = ascending)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim seq As Variant, seqArr As Variant, idx As Variant, s As Variant, d As Variant
Dim i As Integer, arrDim As Integer
Dim LB As Long, UB As Long

    LB = LBound(arr, selDim)
    UB = UBound(arr, selDim)
    ReDim seqArr(UB)

    On Error Resume Next
    Do
        arrDim = arrDim + 1
        seq = UBound(arr, arrDim)
    Loop Until Err.Number <> 0
        arrDim = arrDim - 1
    On Error GoTo 0

    ReDim seq(UB)
'        For i = LB To UB
'        seq(i) = i
'        Next i
'        replaced with
    seq = ArrayAction(seq, , "fillSeries")

    s = Split(Split(selPoint, "(")(1), ")")(0)
    s = Split(s, ",")

    ReDim d(arrDim - 1)
'        For i = 0 To arrDim - 1
'        d(i) = s(i)
'        Next i
'        replaced with
    d = ArrayAction(d, , "fillSequence", s)

    For i = LB To UB

        d(selDim - 1) = i
        Select Case arrDim
            Case Is = 1
                seqArr(i) = arr(d(0))
            Case Is = 2
                seqArr(i) = arr(d(0), d(1))
            Case Is = 3
                seqArr(i) = arr(d(0), d(1), d(2))
            Case Is = 4
                seqArr(i) = arr(d(0), d(1), d(2), d(3))
            Case Is = 5
                seqArr(i) = arr(d(0), d(1), d(2), d(3), d(4))
            Case Is = 6
                seqArr(i) = arr(d(0), d(1), d(2), d(3), d(4), d(5))
            Case Is = 7
                seqArr(i) = arr(d(0), d(1), d(2), d(3), d(4), d(5), d(6))
            Case Is = 8
                seqArr(i) = arr(d(0), d(1), d(2), d(3), d(4), d(5), d(6), d(7))
            Case Is = 9
                seqArr(i) = arr(d(0), d(1), d(2), d(3), d(4), d(5), d(6), d(7), d(8))
            Case Is = 10
                seqArr(i) = arr(d(0), d(1), d(2), d(3), d(4), d(5), d(6), d(7), d(8), d(9))
        End Select

    Next i

    idx = ArrayAction(arr, , "clearArray")

    seq = SortSeq(seqArr, seq, LB, UB, ascend)

    idx = ArrayAction(arr, idx, "sortIndex", seq, selDim)

    SortArray = ArrayAction(arr, idx, "sortArray")

End Function

Private Function ArrayAction(ByVal arr As Variant, _
                    Optional ByRef idx As Variant, _
                    Optional ByRef ActionTag As String = "index", _
                    Optional ByRef seq As Variant, _
                    Optional ByRef sortDim As Integer = 1, _
                    Optional ByRef del As String = ",") As Variant

Dim s As Variant, d As Variant, rArr As Variant, wArr As Variant, oArr As Variant
Dim i As Integer, arrDim As Integer, selDim As Integer

oArr = arr

On Error Resume Next
Do
    arrDim = arrDim + 1
    d = UBound(arr, arrDim)
Loop Until Err.Number <> 0
    arrDim = arrDim - 1
On Error GoTo 0

ReDim d(arrDim - 1)
For i = 0 To arrDim - 1
d(i) = 0
Next i

For selDim = arrDim To 1 Step -1

    If selDim <> arrDim Then

        If d(selDim - 1) = UBound(arr, selDim) Then
            On Error Resume Next
            Do
            d(selDim - 1) = LBound(arr, selDim)
            selDim = selDim - 1
            Loop Until d(selDim - 1) <> UBound(arr, selDim)
            On Error GoTo 0
        End If
        If selDim = 0 Then Exit For
        d(selDim - 1) = d(selDim - 1) + 1
        selDim = arrDim

    End If

    For i = LBound(arr, selDim) To UBound(arr, selDim)

        d(selDim - 1) = i
        'read index
        If Not IsMissing(idx) Then
        Select Case arrDim
            Case Is = 1
                rArr = idx(d(0))
            Case Is = 2
                rArr = idx(d(0), d(1))
            Case Is = 3
                rArr = idx(d(0), d(1), d(2))
            Case Is = 4
                rArr = idx(d(0), d(1), d(2), d(3))
            Case Is = 5
                rArr = idx(d(0), d(1), d(2), d(3), d(4))
            Case Is = 6
                rArr = idx(d(0), d(1), d(2), d(3), d(4), d(5))
            Case Is = 7
                rArr = idx(d(0), d(1), d(2), d(3), d(4), d(5), d(6))
            Case Is = 8
                rArr = idx(d(0), d(1), d(2), d(3), d(4), d(5), d(6), d(7))
            Case Is = 9
                rArr = idx(d(0), d(1), d(2), d(3), d(4), d(5), d(6), d(7), d(8))
            Case Is = 10
                rArr = idx(d(0), d(1), d(2), d(3), d(4), d(5), d(6), d(7), d(8), d(9))
        End Select
        End If

        s = Split(rArr, del)
        'read target cell based on index
        If rArr <> "" Then
        Select Case arrDim
            Case Is = 1
                rArr = oArr(s(0))
            Case Is = 2
                rArr = oArr(s(0), s(1))
            Case Is = 3
                rArr = oArr(s(0), s(1), s(2))
            Case Is = 4
                rArr = oArr(s(0), s(1), s(2), s(3))
            Case Is = 5
                rArr = oArr(s(0), s(1), s(2), s(3), s(4))
            Case Is = 6
                rArr = oArr(s(0), s(1), s(2), s(3), s(4), s(5))
            Case Is = 7
                rArr = oArr(s(0), s(1), s(2), s(3), s(4), s(5), s(6))
            Case Is = 8
                rArr = oArr(s(0), s(1), s(2), s(3), s(4), s(5), s(6), s(7))
            Case Is = 9
                rArr = oArr(s(0), s(1), s(2), s(3), s(4), s(5), s(6), s(7), s(8))
            Case Is = 10
                rArr = oArr(s(0), s(1), s(2), s(3), s(4), s(5), s(6), s(7), s(8), s(9))
        End Select
        End If
        'modify result based on requested action
        wArr = ArrayFunction(ActionTag, rArr, i, d, seq, sortDim, del)
        'write back calculated value
        Select Case arrDim
            Case Is = 1
                arr(d(0)) = wArr
            Case Is = 2
                arr(d(0), d(1)) = wArr
            Case Is = 3
                arr(d(0), d(1), d(2)) = wArr
            Case Is = 4
                arr(d(0), d(1), d(2), d(3)) = wArr
            Case Is = 5
                arr(d(0), d(1), d(2), d(3), d(4)) = wArr
            Case Is = 6
                arr(d(0), d(1), d(2), d(3), d(4), d(5)) = wArr
            Case Is = 7
                arr(d(0), d(1), d(2), d(3), d(4), d(5), d(6)) = wArr
            Case Is = 8
                arr(d(0), d(1), d(2), d(3), d(4), d(5), d(6), d(7)) = wArr
            Case Is = 9
                arr(d(0), d(1), d(2), d(3), d(4), d(5), d(6), d(7), d(8)) = wArr
            Case Is = 10
                arr(d(0), d(1), d(2), d(3), d(4), d(5), d(6), d(7), d(8), d(9)) = wArr
        End Select

    Next i

Next selDim

ArrayAction = arr

End Function

Private Function ArrayFunction(ByRef ActionTag As String, _
                    ByRef rArr As Variant, _
                    ByRef i As Integer, _
                    ByVal d As Variant, _
                    ByRef seq As Variant, _
                    ByRef sortDim As Integer, _
                    ByRef del As String) As Variant

Select Case ActionTag
    Case Is = "sortIndex"
        d(sortDim - 1) = seq(d(sortDim - 1))
    Case Is = "fillZero"
        ArrayFunction = 0
        Exit Function
    Case Is = "fillSeries"
        ArrayFunction = i
        Exit Function
    Case Is = "fillSequence"
        ArrayFunction = seq(i)
        Exit Function
    Case Is = "sortArray"
        ArrayFunction = rArr
        Exit Function
    Case Is = "clearArray"
        ArrayFunction = Empty
        Exit Function
End Select

Select Case UBound(d)
    Case Is = 0
        ArrayFunction = d(0)
    Case Is = 1
        ArrayFunction = d(0) & del & d(1)
    Case Is = 2
        ArrayFunction = d(0) & del & d(1) & del & d(2)
    Case Is = 3
        ArrayFunction = d(0) & del & d(1) & del & d(2) & del & d(3)
    Case Is = 4
        ArrayFunction = d(0) & del & d(1) & del & d(2) & del & d(3) & del & d(4)
    Case Is = 5
        ArrayFunction = d(0) & del & d(1) & del & d(2) & del & d(3) & del & d(4) & del & d(5)
    Case Is = 6
        ArrayFunction = d(0) & del & d(1) & del & d(2) & del & d(3) & del & d(4) & del & d(5) & del & d(6)
    Case Is = 7
        ArrayFunction = d(0) & del & d(1) & del & d(2) & del & d(3) & del & d(4) & del & d(5) & del & d(6) & del & d(7)
    Case Is = 8
        ArrayFunction = d(0) & del & d(1) & del & d(2) & del & d(3) & del & d(4) & del & d(5) & del & d(6) & del & d(7) & del & d(8)
    Case Is = 9
        ArrayFunction = d(0) & del & d(1) & del & d(2) & del & d(3) & del & d(4) & del & d(5) & del & d(6) & del & d(7) & del & d(8) & del & d(9)
End Select

End Function

Private Function SortSeq(ByRef iArr As Variant, ByRef sArr As Variant, ByRef iDnRow As Long, ByRef iUpRow As Long, Optional ByRef ascend As Boolean = True) As Variant

Dim oArr As Variant, vArr As Variant
Dim vDnRow As Long, vUpRow As Long

vDnRow = iDnRow
vUpRow = iUpRow
oArr = iArr((iDnRow + iUpRow) \ 2)

While (vDnRow <= vUpRow)

If ascend = True Then
    While (iArr(vDnRow) < oArr And vDnRow < iUpRow)
       vDnRow = vDnRow + 1
    Wend
    While (oArr < iArr(vUpRow) And vUpRow > iDnRow)
       vUpRow = vUpRow - 1
    Wend
Else
    While (iArr(vDnRow) > oArr And vDnRow < iUpRow)
       vDnRow = vDnRow + 1
    Wend
    While (oArr > iArr(vUpRow) And vUpRow > iDnRow)
       vUpRow = vUpRow - 1
    Wend
End If

If (vDnRow <= vUpRow) Then
   vArr = iArr(vDnRow)
   iArr(vDnRow) = iArr(vUpRow)
   iArr(vUpRow) = vArr
   vArr = sArr(vDnRow)
   sArr(vDnRow) = sArr(vUpRow)
   sArr(vUpRow) = vArr
   vDnRow = vDnRow + 1
   vUpRow = vUpRow - 1
End If

Wend

If (iDnRow < vUpRow) Then SortSeq iArr, sArr, iDnRow, vUpRow, ascend
If (vDnRow < iUpRow) Then SortSeq iArr, sArr, vDnRow, iUpRow, ascend

SortSeq = sArr

End Function

Simple test sub:

Sub testSortArray()

Dim arr As Variant, indexArr As Variant, s As Variant

ReDim arr(1, 1, 5)

arr(0, 0, 0) = 0
arr(0, 0, 1) = 1
arr(0, 0, 2) = 2
arr(0, 0, 3) = 3
arr(0, 0, 4) = 4
arr(0, 0, 5) = 5
arr(0, 1, 0) = 10
arr(0, 1, 1) = 11
arr(0, 1, 2) = 12
arr(0, 1, 3) = 13
arr(0, 1, 4) = 14
arr(0, 1, 5) = 15
arr(1, 0, 0) = 100
arr(1, 0, 1) = 101
arr(1, 0, 2) = 102
arr(1, 0, 3) = 103
arr(1, 0, 4) = 104
arr(1, 0, 5) = 105
arr(1, 1, 0) = 110
arr(1, 1, 1) = 111
arr(1, 1, 2) = 112
arr(1, 1, 3) = 113
arr(1, 1, 4) = 114
arr(1, 1, 5) = 115

arr = SortArray(arr, "(1,1,0)", 3, False)
indexArr = ArrayAction(arr)

End Sub
Improve this question
\$\endgroup\$
1

2 Answers 2

Reset to default
4
\$\begingroup\$

Meaningful Variable Names

What is s?, what is d? It is a (pretty much universal) law of programming that single-character variables are counters of some description. Yet these most definitely aren't. I spent a good 5 minutes looking through your code just to figure out what kind of data they contained, let alone what their purpose is. Don't abbreviate variable names (at last not until you've gotten used to written descriptive ones). Don't use meaningless names except for meaningless variables.

variables should sound like what they are. 1-dimensional arrays should sound like a list/sequence of stuff e.g. dim sequenceOfThings as array(). THE 10-dimensional array this whole thing was built for should have a far more meaningful name than arr. Even mainArr would be so much better.

What's the difference between seq, seqArr, s and d? I haven't got the faintest idea, and I'm too tired to wade through your code trying to figure it out. Give them descriptive, meaningful names. Even if it means your variables are called arrayOfThingsArrangedLikeSo, that is far better than the opposite.

Recursion (Or: Don't Repeat Yourself, A.K.A. DRY)

(Or, if you are forced to, and cannot change the wider contextual structure of the program, at least tuck them away in separate functions).

For i = LB To UB

    d(selDim - 1) = i
    Select Case arrDim
        Case Is = 1
            seqArr(i) = arr(d(0))
        Case Is = 2
            seqArr(i) = arr(d(0), d(1))
        Case Is = 3
            seqArr(i) = arr(d(0), d(1), d(2))
        Case Is = 4
            seqArr(i) = arr(d(0), d(1), d(2), d(3))
        Case Is = 5
            seqArr(i) = arr(d(0), d(1), d(2), d(3), d(4))
        Case Is = 6
            seqArr(i) = arr(d(0), d(1), d(2), d(3), d(4), d(5))
        Case Is = 7
            seqArr(i) = arr(d(0), d(1), d(2), d(3), d(4), d(5), d(6))
        Case Is = 8
            seqArr(i) = arr(d(0), d(1), d(2), d(3), d(4), d(5), d(6), d(7))
        Case Is = 9
            seqArr(i) = arr(d(0), d(1), d(2), d(3), d(4), d(5), d(6), d(7), d(8))
        Case Is = 10
            seqArr(i) = arr(d(0), d(1), d(2), d(3), d(4), d(5), d(6), d(7), d(8), d(9))
    End Select

Next i

So, I can't think of a simpler way to express this, but you can, at least, put this whole thing in a function called GetIndexedElementInSelDim arr, seldim, i like so:

 For i = LB To UB

    d(selDim - 1) = i
    seqArr(i) = GetIndexedElementFromSelDim(arr, selDim, i)

 Next i

Public Function GetIndexedElementFromSelDim(ByRef arr As Variant, ByVal selDim As Integer, ByVal i As Integer)

    Dim value As Variant

        Select Case arrDim
            Case Is = 1
                value = arr(d(0))
            Case Is = 2
                value = arr(d(0), d(1))
            Case Is = 3
                value = arr(d(0), d(1), d(2))
            Case Is = 4
                value = arr(d(0), d(1), d(2), d(3))
            Case Is = 5
                value = arr(d(0), d(1), d(2), d(3), d(4))
            Case Is = 6
                value = arr(d(0), d(1), d(2), d(3), d(4), d(5))
            Case Is = 7
                value = arr(d(0), d(1), d(2), d(3), d(4), d(5), d(6))
            Case Is = 8
                value = arr(d(0), d(1), d(2), d(3), d(4), d(5), d(6), d(7))
            Case Is = 9
                value = arr(d(0), d(1), d(2), d(3), d(4), d(5), d(6), d(7), d(8))
            Case Is = 10
                value = arr(d(0), d(1), d(2), d(3), d(4), d(5), d(6), d(7), d(8), d(9))
        End Select

        GetIndexedElementFromSelDim = value

End Function

And then put that function down the bottom of your module.

There are at least 4 more select case statements in your program that can be similarly shortened.

Document Your Code

I spent most of the time reviewing this just trying to figure out what everything was doing and why (see also: Meaningful Names, Descriptive function names). You (or somebody who has to maintain your code in a year's time) should be able to tell at a glance what bits of your program are supposed to be doing (and, preferably, why).

If I'm writing a function with more than 20 lines or so (and even for shorter ones, if it's doing something particularly non-intuitive) I write this first:

'/======================================================================================================================================================
'/ Author:  Zak Armstrong
'/ Email:   zak.Armstrong@<company domain>
'/
'/ Description:
'/ First creates a 1D array of: inputValues from the userForm and <Process Step> objects, with column spaces.
'/ Then converts this to a 1D array of: inputValues and values from the <Process step> objects, retaining column spaces. Ready to Print to a Worksheet.
'/ Then prints to the next unused line on the Process_List worksheet.
'/======================================================================================================================================================

Even if the description is just:

"Takes data in [format], transposes it and returns it in [format]"

(though in this case, that's usually something that can be described in the name of the function itself). It saves so much time when you don't have to try and figure out what everything is doing and why.

As an example, here's the main sub for a recent big project of mine:

Public Sub GenerateAdviserSubmissionReports()

    StartTimer

    StoreApplicationSettings

    DisableApplicationSettings

    '/======================================================================================================================================================
    '/  Author:  Zak Armstrong
    '/  Email:   zak.armstrong@<Company Domain>
    '/  Date:    21/August/2015
    '/  Version: 0.3
    '/
    '/  Description:    All Lumin Wealth Business is contained in the Subsheet. This macro produces adviser totals for business (assets and fees) in the previous year
    '/                  (month by month breakdown) by aggregating the subsheet into one giant table and then assigning each piece of business to an adviser, a Month and a business type.
    '/                  The report can then be easily configured for any desired outputs (E.G. by adviser, by provider, by type of business)
    '/======================================================================================================================================================
        InitialiseGlobalsBooksSheetsAndCollections

        GetAllSheetDataIntoArrays

        FilterSheetArrays

        AggregateSheetData

        CloseWorkbook WbSubsheet

        PrintAggregatedData

        CleanUpAggregatedData

        AllocateBusiness

        GenerateReportByAdviser

        GenerateReportByProvider

        GenerateReportByMetric

    RestoreApplicationSettings

    EndTimer

End Sub

It's full of functions like:

PutSheetDataInArray ws, arrWsData

AssignArrayBounds arr, LB1, UB1

CopyArrayContents arrSource, arrTarget

TransposeArray arr

IndexInArray searchText, arrList

AssignCurrentBookAndSheet this_Ws, This_Wb

ArrayElementsToStrings arrData

ListOfUniqueValues arrList, arrUniqueValues

SortRangeHiLo dataTable, HiLo:= True, colSortKey:= colSortKey

Now contrast that with:

ArrayAction arr, idx, ActionTag, seq, sortDim, del

ArrayFunction ActionTag. rArr, i, d, seq, sortDim, del

SortSeq iArr, sArr, iDnRow, iUpRow, ascend

SortArray arr, selPoint, selDim, ascend

And you may know what they all mean while they're fresh in your memory, but I guarantee that you in 6 months, or anybody else who needs to maintain your code will be absolutely clueless.

I would much rather maintain code written like an essay, than code written like a tweet.

Improve this answer
\$\endgroup\$
10
  • \$\begingroup\$ Ok, Zak, you're right, the variable names should have meaningful names, but for sake of visibility I have preferred to keep it short. s = sequence index, d = dimension index, and usually I use r for read, w for write, v for virtual (same as temp), o for output, difference between seq and seqArr depends on context, both are sequence arrays which would see better like sequenceArray1 and sequenceArray2 . I'm pretty sure that you'll manage to understand the code. \$\endgroup\$
    – Sorin GFS
    Oct 3, 2015 at 0:37
  • \$\begingroup\$ I suggest you code by the following rule: If your function is longer than 20 lines, then you never shorten your variable names. If things are too big to fit on one line, split them into multiple operations on multiple lines. Or use " _" (leading space) which runs the line underneath as if it were on the end of the current line. \$\endgroup\$
    – Kaz
    Oct 3, 2015 at 9:05
  • 2
    \$\begingroup\$ Meaningful names are Far more important than making your code look neat. \$\endgroup\$
    – Kaz
    Oct 3, 2015 at 9:21
  • 1
    \$\begingroup\$ There are plenty of ways to reduce code spread and use longer, meaningful names, mainly by refactoring things into smaller functions then just calling the function. I've realised what I misunderstood about what your code is doing (hint: this is exactly why descriptive names are so important) and changed my answer accordingly. \$\endgroup\$
    – Kaz
    Oct 3, 2015 at 11:18
  • 2
    \$\begingroup\$ You asked for improvement ideas. All of these things are far more important improvements than making it a bit faster (or whatever functionality you're specifically thinking of). \$\endgroup\$
    – Kaz
    Oct 3, 2015 at 13:54
4
\$\begingroup\$

Just a quick comment. According to your header, you're making assumptions about the argent values. For example:

'3) selDim      = selected dimension, integer from 1 to 10

But you never do any checking of those values. So one of two things will happen when calling the function with invalid arguments.

  1. Runtime errors are thrown from deep within the function and the caller has to dig into the internals to figure out where things went wrong. (Thankfully, they only have to look at your header, good job!)
  2. Undefined behavior occurs and the caller silently gets wrong results. This is bad. Very bad.

Do some defensive programming and check all of the incoming args before the real work of your method begins. If something is out of range, or otherwise invalid, raise an error with a meaningful and clear message for the developer calling your function.

For example:

If (UBound(arr) - LBound(arr)) > 10 Then
    Err.Raise 5, "ModuleName.SortArray", "Arrays larger than ten dimensions are not supported."
End If

If selDim > 10 Then
     Err.Raise 5, "ModuleName.SortArray", "Argument [selDim] is out of range. It cannot be greater than 10, but was passed with a value of [" & selDim & "]."
End If

If you're curious why I choose error number 5, it's because it's the internal error number for Invalid Procedure Call or Argument. In a real life situation I would define a constant for it.

Improve this answer
\$\endgroup\$
2
  • \$\begingroup\$ You're right. This function is a continuation of Deca dimensional ascending and descending array sort function, where I specified why I don't use any error handler. I forgot to specify here too. \$\endgroup\$
    – Sorin GFS
    Oct 3, 2015 at 13:24
  • 2
    \$\begingroup\$ "I didn't put any error handler, because depending on usage purposes, it can take different shapes." @SorinGFS, no offense meant, but that's nonsense. Utter nonsense. There are obvious cases and ranges this function is meant to work within. It should be validated that the call to it is valid. But hey... If you're ok with undefined behavior, it's your headache, not mine. \$\endgroup\$
    – RubberDuck
    Oct 3, 2015 at 13:27

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.