Sorting multi columns in an array

[LisaGreen]

Hello!

I'm writing VBA to export vba procedures to a text file.
For this I'm creating an array of details containing...
Project Name
Module Name
Procedure Name
Module ProcStartLine
Module ProcBodyLine
Procedure ProcCountLines
Procedure Endline
Procedure Type

I'd like to sort the array on
Procedure name
Module Name
Project Name
ProcCountLines

.. in that order.

Can some one help point me to a site or even better does someone have code, to do that please.

There seems to be a lot on the internet about sorting arrays on one element but not on sorting an array on four elements.

TIA
Lisa

[HansV]

Try sorting on the least important column first, then the next-to-least important column, etc.

[Jay Freedman]

Try sorting on the least important column first, then the next-to-least important column, etc.

Whether this will get the result you want depends on which sorting algorithm you use, specifically on whether the algorithm is "stable". What that means is explained in this quote from https://stackoverflow.com/questions/151 ... -important:

A sorting algorithm is said to be stable if two objects with equal keys appear in the same order in sorted output as they appear in the input array to be sorted. Some sorting algorithms are stable by nature like Insertion sort, Merge Sort, Bubble Sort, etc. And some sorting algorithms are not, like Heap Sort, Quick Sort, etc.

To do multiple sorts, each on a different key (column), you want a stable algorithm. An unstable algorithm has the possibility of scrambling the order of the previously sorted columns.

If you aren't sure what algorithm is used by some canned function that your code calls, try it on some dummy data and see what happens.

[HansV]

Thanks, Jay. Excellent point.

[LisaGreen]

Whoo!!!

Thank you Jay!!!

Good reading!

Lisa

[LisaGreen]

Hello everyone,

How about this... not got any code yet, just thinking about it.

Suppose we have slArray(n,5) and we want to sort on "cols" 3,2,0 in that order.

1. Always sort on the first column. = 3.
2. Now go down column 3 and get the LBound and UBound for n of sections of col 3 that are the same.
3. Copy those rows to a slSubArray.
4. Sort the sub array on the next Col to sort. = 2.
5. Put the rows back.
6. Loop until n and all the sections have been sorted and put back.
7. Now go down col 2 and do the same. Get LBound and UBound of sections in col 2 that are the same.
8. Copy those rows to a slSubArray
9. Sort the sub array on the next Col to sort. = 0.
10. Put the rows back.
11. Loop until n and all the sections have been sorted and put back.

Does anyone have an opinion please?
Would it work?

TIA
Lisa

[HansV]

I haven't tried it, but I suspect that it would be slow if the array has many rows.

[LisaGreen]

Hello Hans,

Speed is not really an issue.

As I mentioned, it's for a listing of procedures across VBA projects.

I personally have about 4k procedures over about 30 projects, so the estimate is about 4k "rows".

One of the reasons for doing this is to sort out ( out intended! ) obvious duplicates. I *know* I've written the same code over and over!! ANd I know, that I've imported complete modules to files.

Lisa

[HansV]

I'd say go for it...

[LisaGreen]

Going to give it a try then!!!

I'll let you know.

Lisa

[LisaGreen]

Hi,

I already had this nearly complete so I rushed a bit to finish. I'm pretty sure it works. I've tried with some excel data on a sheet.

If anyone has the time I'd appreciate it if you find out if it doesn't work.

TIA
Lisa

Code: Select all

Sub subSort2DArrayMultiElements( _
            sparray() As String, _
            spOrder As String _
            )
' Sort an array with TWO dimensions.
' Assume Sort on the 2nd Dimension
'  so assumes it IS a 2 Dim array.
' Sort on more than one element.
'
' This uses a merge sort.
' The sort is set up as ascending and not case sensitive.
'
' Use
'    subSortMultiElements Array, Order
'
' Ex Order = "1 4 0 3 2".
' Not all elements need be specified.
' Any delimiter may be used.
'

Dim lnglArrayIndex As Long
Dim lnglElements As Long
Dim lnglEndArray As Long
Dim lnglKey As Long
Dim lnglLbound As Long
Dim lnglM As Long
Dim lnglN As Long
Dim lnglNumSortKeys As Long
Dim lnglO As Long
Dim lnglP As Long
Dim lnglPrevKeyCol As Long
Dim lnglThisKeyCol As Long
Dim lnglUBound As Long
Dim lngSubArrayRows As Long
Dim slKeyVal As String
Dim slOrder As String
Dim slOrderArray() As String
Dim slSubArray() As String
Dim slTopKeyVal As String

lnglElements = UBound(sparray, 2)

' Make an Order Array.
slOrder = spOrder

' Delimiter?
' Disappear the numbers.
For lnglN = 0 To 9
  slOrder = Replace(slOrder, CStr(lnglN), "")
Next lnglN
slOrder = Trim$(slOrder)

' Should only have the delimiter left.
If Len(slOrder) = 0 Then
  slOrderArray = Split(spOrder, " ")
Else
  slOrderArray = Split(spOrder, Mid$(slOrder, 1, 1))
End If

lnglNumSortKeys = UBound(slOrderArray) + 1

' Always Sort on the FIRST Key.
lnglKey = CLng(slOrderArray(0))
subArrayMergeSort sparray, lnglKey

' Only one key?
If lnglNumSortKeys = 1 Then

  Exit Sub

End If

' Now go through the rest of the keys.
' We extract a series of arrays based on the KEY - 1.
' Any records to sort?
If UBound(slOrderArray) > 0 Then
  For lnglN = 1 To lnglNumSortKeys - 1
      
    ' Pick up the start Value from Key-1.
    lnglPrevKeyCol = slOrderArray(lnglN - 1)
    lnglThisKeyCol = slOrderArray(lnglN)
    
    slTopKeyVal = sparray(0, lnglPrevKeyCol)
    
    lnglLbound = 0
    lnglUBound = UBound(sparray, 1)
    
    ' All the same.
    If sparray(lnglUBound, 0) = slTopKeyVal Then
      Exit For
    End If
    
    lnglArrayIndex = 0
    lnglEndArray = UBound(sparray)
    Do
      lnglLbound = lnglArrayIndex
      slTopKeyVal = sparray(lnglArrayIndex, lnglPrevKeyCol)
      Do
        If lnglArrayIndex > lnglEndArray Then
          Exit Do
        End If
      
        slKeyVal = sparray(lnglArrayIndex, lnglPrevKeyCol)
        
        If slKeyVal <> slTopKeyVal Then
          
          lnglUBound = lnglArrayIndex - 1
          Exit Do
          
        End If
      
        lnglArrayIndex = lnglArrayIndex + 1
      
      Loop
      
      ' No need to sort if there's only ONE row.
      lngSubArrayRows = lnglUBound - lnglLbound
      If lngSubArrayRows > 1 Then
      

        ' Get those rows.
        ReDim slSubArray(lnglUBound - lnglLbound, lnglElements)
        lnglP = 0
        For lnglM = lnglLbound To lnglUBound
          For lnglO = 0 To lnglElements
            slSubArray(lnglP, lnglO) = sparray(lnglM, lnglO)
          Next lnglO
          lnglP = lnglP + 1
        Next lnglM
        
        ' Sort 'em.
        subArrayMergeSort slSubArray, lnglThisKeyCol
        
        ' Put 'em back.
        lnglP = 0
        For lnglM = lnglLbound To lnglUBound
          For lnglO = 0 To lnglElements
            sparray(lnglM, lnglO) = slSubArray(lnglP, lnglO)
          Next lnglO
          lnglP = lnglP + 1
        Next lnglM
        
      End If
      
      If lnglArrayIndex > lnglEndArray Then
        Exit Do
      End If
    
    Loop
    
  Next lnglN
End If

' ***********************************************************************
End Sub

[LisaGreen]

oops... Forgot the merge sort. It's a steal from VBForums.

I sort of like the function I posted because you can use any sort you like really and there are lots on the internet for a single column in a 2d array.

Jays point is well made!

Lisa

Code: Select all

Sub subArrayMergeSort( _
            ByRef vpArray As Variant, _
            ByVal lngpElement As Long, _
            Optional vpMirror As Variant, _
            Optional ByVal lngpLeft As Long, _
            Optional ByVal lngpRight As Long _
            )
' http://www.vbforums.com/showthread.php?t=473677
'
' Recurse Merge Sort a TWO Dim array.
'
' Use...
'  subMergeSort Array, Element
'
' lngpLeft and lngpRight are 0 at the start.
'
' Sorts on ONE element.
'

Dim blnlRightIsLessThanLeft As Boolean
Dim blnlLeftIsGreaterThanRight As Boolean
Dim blnlIsNumeric As Boolean
Dim lnglLeftStart As Long
Dim lnglMid As Long
Dim lnglOutputStart As Long
Dim lnglRightStart As Long
Dim vlSwap As Variant
Dim lnglCElement As Long
Dim lnglNumElements As Long
Dim vlSwapRow() As Variant

' This is just to gain a tiiiny bit of speed.
If IsNumeric(vpArray(0, lngpElement)) = True Then
  blnlIsNumeric = True
Else
  blnlIsNumeric = False
End If

lnglNumElements = UBound(vpArray, 2)
ReDim vlSwapRow(lnglNumElements)
If lngpRight = 0 Then
  lngpLeft = LBound(vpArray, 1)
  lngpRight = UBound(vpArray, 1)
  ReDim vpMirror(lngpLeft To lngpRight, 0 To lnglNumElements)
End If
lnglMid = lngpRight - lngpLeft

Select Case lnglMid
Case 0

Case 1
  
  ' Changed this to make it case insensitive.
  ' If vpArray(lngpLeft) > vpArray(lngpRight) Then
  If blnlIsNumeric = True Then
    If CLng(vpArray(lngpLeft, lngpElement)) _
      > CLng(vpArray(lngpRight, lngpElement)) _
    Then
        blnlLeftIsGreaterThanRight = True
    Else
        blnlLeftIsGreaterThanRight = False
    End If
  Else
    If StrComp( _
        vpArray(lngpLeft, lngpElement), _
        vpArray(lngpRight, lngpElement), _
        vbTextCompare) _
        = 1 _
    Then
      blnlLeftIsGreaterThanRight = True
    Else
      blnlLeftIsGreaterThanRight = False
    End If
  End If
  
  If blnlLeftIsGreaterThanRight Then
    
    ' SWAP the whole row.
    For lnglCElement = 0 To lnglNumElements
      vlSwapRow(lnglCElement) = vpArray(lngpLeft, lnglCElement)
    Next lnglCElement
    
    For lnglCElement = 0 To lnglNumElements
      vpArray(lngpLeft, lnglCElement) = vpArray(lngpRight, lnglCElement)
    Next lnglCElement
    
    For lnglCElement = 0 To lnglNumElements
      vpArray(lngpRight, lnglCElement) = vlSwapRow(lnglCElement)
    Next lnglCElement
    
'    vlSwap = vpArray(lngpLeft)
'    vpArray(lngpLeft) = vpArray(lngpRight)
'    vpArray(lngpRight) = vlSwap
  
  End If

Case Else
  
  lnglMid = lnglMid \ 2 + lngpLeft
  subArrayMergeSort vpArray, lngpElement, vpMirror, lngpLeft, lnglMid
  subArrayMergeSort vpArray, lngpElement, vpMirror, lnglMid + 1, lngpRight

  ' Merge the resulting halves
  
  lnglLeftStart = lngpLeft ' start of first (left) half
  lnglRightStart = lnglMid + 1  ' start of second (right) half
  lnglOutputStart = lngpLeft  ' start of output (mirror array)
  
  Do
    
    ' Changed this to make it case insensitive.
    ' If vpArray(lnglRightStart) < vpArray(lnglLeftStart) Then
    
    If blnlIsNumeric = True Then
    
      If CLng(vpArray(lnglRightStart, lngpElement)) _
          < CLng(vpArray(lnglLeftStart, lngpElement)) _
      Then
        blnlRightIsLessThanLeft = True
      Else
        blnlRightIsLessThanLeft = False
      End If
    Else
      If StrComp( _
          vpArray(lnglRightStart, lngpElement), _
          vpArray(lnglLeftStart, lngpElement), _
          vbTextCompare) = _
          -1 _
      Then
        blnlRightIsLessThanLeft = True
      Else
        blnlRightIsLessThanLeft = False
      End If
    End If
    
    If blnlRightIsLessThanLeft Then
    
      ' COPY the complete row.
'      vpMirror(lnglOutputStart) = vpArray(lnglRightStart)
      For lnglCElement = 0 To lnglNumElements
        vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglRightStart, lnglCElement)
      Next lnglCElement
      
      
      lnglRightStart = lnglRightStart + 1
      If lnglRightStart > lngpRight Then
        For lnglLeftStart = lnglLeftStart To lnglMid
          lnglOutputStart = lnglOutputStart + 1
          
          ' COPY the whole row.
'          vpMirror(lnglOutputStart) = vpArray(lnglLeftStart)
          For lnglCElement = 0 To lnglNumElements
            vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglLeftStart, lnglCElement)
          Next lnglCElement
                 
        Next
        Exit Do
      End If
    Else
    
      ' COPY the complete row.
'      vpMirror(lnglOutputStart) = vpArray(lnglLeftStart)
      For lnglCElement = 0 To lnglNumElements
        vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglLeftStart, lnglCElement)
      Next lnglCElement
      
      
      lnglLeftStart = lnglLeftStart + 1
      If lnglLeftStart > lnglMid Then
        For lnglRightStart = lnglRightStart To lngpRight
          lnglOutputStart = lnglOutputStart + 1
          
          ' COPY the complete row.
'          vpMirror(lnglOutputStart) = vpArray(lnglRightStart)
          For lnglCElement = 0 To lnglNumElements
            vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglRightStart, lnglCElement)
          Next lnglCElement
          
        Next
        
        Exit Do
      End If
    End If
    
    lnglOutputStart = lnglOutputStart + 1
  
  Loop
  For lnglOutputStart = lngpLeft To lngpRight
    
    ' Swap the complete row.
'    vpArray(lnglOutputStart) = vpMirror(lnglOutputStart)
    For lnglCElement = 0 To lnglNumElements
      vpArray(lnglOutputStart, lnglCElement) = vpMirror(lnglOutputStart, lnglCElement)
    Next lnglCElement
    
  Next
End Select

' *********************************************************************
End Sub

[Doc.AElstein]

Hi Lisa,
I expect as usual I missed the point and don’t quite understand what it is that you are doing or wanting to do. …
But anyways… I just made some attempt at testing your routines. ( I have not done much sorting of arrays myself )

_1 ) I note that the array you pass in the variant variable vpArray in the signature line of Sub subArrayMergeSort must have a 1st dimension indicie of 0, or else this line will error
If IsNumeric(vpArray(0, lngpElement)) = True Then

_2 ) I wrote a short test code to call Sub subSort2DArrayMultiElements
It captures a test range which is any range you care to select in a spreadsheet. It turns that into a 2 dimensional String type element Array, DumDom(), ( with first element indicie of 0, 0 )
That DumDom() Array is then fed into your Sub subSort2DArrayMultiElements
I don’t really know what it is that your Sub subSort2DArrayMultiElements is supposed to do. I took a guess that maybe it should re arrange my Array, DumDom()
So my test code pastes out DumDom() after running your routines. It pastes it out for ease of comparison to the right of the original selection which it was filled with.

Here is my test code:

Code: Select all

 Sub TestsStringArray()
Dim arrSel() As Variant
 Let arrSel() = Selection.Value
Dim DumDom() As String: ReDim DumDom(0 To UBound(arrSel(), 1) - 1, 0 To UBound(arrSel(), 2) - 1)
Dim rCnt As Long, cCnt As Long
    For rCnt = 0 To UBound(arrSel(), 1) - 1
        For cCnt = 0 To UBound(arrSel(), 2) - 1
         Let DumDom(rCnt, cCnt) = CStr(arrSel(rCnt + 1, cCnt + 1))
        Next cCnt
    Next rCnt
 Call subSort2DArrayMultiElements(DumDom(), "1 2")
' Paste reorganised Array next to the selection
Dim OutRange As Range: Set OutRange = Selection.Offset(0, Selection.Columns.Count)
 Let OutRange.Value = DumDom()
End Sub

Here is a test of the test code and your codes with some results.
http://www.excelfox.com/forum/showthrea ... #post10926 https://tinyurl.com/yamoueq3" onclick="window.open(this.href);return false;
Yellow is the range I used for the selection, that is to say, that range was selected when I ran my test code.So Yellow is effectively my Array DumDom(). Green is what my Array DumDom() looks like after your coding is finished with it.
I have no idea if I am doing anything like the testing that you were asking for….
I expect I haven’t quite grasped what it is that you want..
I will go and re - read your book now instead I think :)

Alan

[LisaGreen]

@Alan

Hi Alan.

WHere I'm going with all of my latest posts is to be able to obtain a list of procedures across at least DOCM and XLSM files. Time is not an issue. And I want them sorted. I can't assume that a person has excel on their computer so I'm choosing for a VBA solution.

I've added a new "column" to my requirements as well. I need the filename.

I know I've exported and imported complete modules over the years and then updated some procedures in some modules and added or deleted others.
Once I have a complete list, working on that now with LOTS of help from Hans!!, I can sort on Module name/procedure name/number of lines for example. That will give me an idea of what procedures are exactly the same that are in different projects in different files. I can sort on procedure name/number of lines for the same thing. I can sort on procedure name/module name/project name.... and so on and so on.

My Q in this thread is...
I have a 2D array.
How do I sort on a number of columns from dimension 2.

There is a lot on the web about sorting a 2D array on a single "column".
As you can see from the above, I'd like to sort on as many columns as I want.

i'm going to look at your comments tomorrow... Going to bed now!!!

Greeeetz to Petra!
Lisa

[Doc.AElstein]

Hello .. Lisa and all…

I remember I never did get the point completely of what was wanted here… but I did at least remember the Thread..
I just did something for myself, and what I have does fit the Thread title. So there might be something in it that is useful for anyone that hits this Thread on a search….

What I done is an VBA array alternative to the VBA Range.Sort method.
In particular, I was doing an alternative to an existing sort coding of mine: Currently, I use in a large file , a 3 key , simple single line version of the VBA Range.Sort method, which , simplified looks like this

Rng.Sort Key1:=Rng.Columns("A:A"), order1:=xlDescending, Key2:=Rng.Columns("C:C"), order2:=xlAscending, Key3:=Rng.Columns("E:E"), order3:=xlAscending, MatchCase:=False

For anyone that does not recognise that , it does the following:
Rng would be some 2 D spreadsheet area
The rows will get sorted initially based on looking at the values in the first column. If all the values are different in the first column, then that is the end of it.
But if for example, some rows had exactly the same value in the first column, then those rows would be sorted again based on the values in column 3.
If that last sort still left rows with the same value in both column 1 and column 3 then another attempt is made at a sort of those similar rows , based on the values in column 5.

That works great for me.
Many people find that the VBA Range.Sort method is so good, that even if they want to sort an array, then they often paste the array out to a spare spreadsheet range, do the sort with the VBA Range.Sort method on that range , then re capture the sorted range back to the array.
But I like to have alternatives, especially ones not interacting with a spreadsheet, so I did an array version

In the file uploaded is a worked example. I use a spreadsheet for the demo data, just because that is convenient for a demo, and also as I do the same sort with the VBA Range.Sort method code line above, just for comparison.
My routine is all internal using VBA arrays. ( My actual data sizes are a lot bigger: I just have a small data range example here to make it easier to demo)

The worked example I do ( all made up and greatly simplified compared to my actual data ), imagines I have a list of food products in no particular order
Unsorted Food List.JPG : https://imgur.com/W3PHRUs" onclick="window.open(this.href);return false;

Unsorted Food List.JPG

For the sake of demo , lets say I want to
_ Group all food types together – sort based on column 1
Then I want to order them in terms of the least unhealthy so
_ next sort based on the calories (Kcal) in column 3
_ If any product has the same Kcal, then next sort is to be on Salt content , column 5

There are two routines in the uploaded file. The first is just the code to test/ demo, Sub TestSimpleArraySort6() . That test routine uses the spreadsheet range to get an array of data to sort in the main array sort routine, Sub SimpleArraySort6( ) . The test routine Calls the main routine. It also does the same Sort for comparison using the 3 key VBA Range.Sort code line.
Finally, after the called routine has finished sorting , the test/demo routine pastes out the results from both methods alongside the original range. The results from my array sort routine is highlighted in Yellow, and the results from the VBA Range.Sort method is shown highlighted in green.
Simple Sort Results.JPG : https://imgur.com/9MbP9To" onclick="window.open(this.href);return false;

Simple Sort Results.JPG

I have done a simple Bubble sort method. Any other refinements like the issues discussed in this Thread need a level of thought and mathematical understanding that have long since left me unfortunately, :(

My routine is based on recursion techniques. It is called once. At that first Call you give it arguments which I have tried to make look a bit similar to those used in the VBA Range Sort Method single code line. My routine then sets off other copy runs of the routine as it needs to sort by other columns. Theoretically it does not have a limit on the number of columns ( keys ) you give it to sort by. ( The Range.Sort Method is limited to 3 keys in the single line use, but that can also do more if you .Add them in separate rows before .Applying it )
I have only tested it so far with a small range using 3 keys as a direct comparison with the simple single line use of the VBA Range.Sort method

If you have a few weeks spare and are interested in a full explanation of the coding development, then it starts from about here… http://www.excelfox.com/forum/showthrea ... simple-use https://tinyurl.com/y3mon7pp" onclick="window.open(this.href);return false;

Alan

_._____

In the uploaded file, enable macros then run the test code…. Sub TestSimpleArraySort6()
The coding is still in its full spread out , and probably not very efficient, form. I expect I may simplify it and optimise it a bit sometime. I will keep the version updated at that link, and maybe update the file here …