[b]AutoBuddy AutoSort Function for XL[/b]

[N1GHTEYES]

Here is a function - AL_Autosort_1D() - which is a way to generate an automatic sort function in Excel. In other words it is live - you change the input data and this changes. Furthermore, you do not need to specify the input data - just paste this function next to any 1D array (column or row) and it will give you a sorted version of it. So, for example, if you have data in cells A1:A107 and you paste this function (as an array formula) into B1:B107, then B1:B107 will become a sorted version of the intital data. And it will be live - if you change any cell in A1:A107 then the output will change.

And yes - I do know you can do something similar using the Rank() and Index() functions, but this takes up 1 less column on the sheet and slightly less of your time creating the setup. It is also a bit easier for less experienced users than sorting out the logic required for the use of the Rank() version.

If you don't want the "buddy" part - i.e. you do want to specify exactly where your source data lies, you can. AL_Autosort_1D() calls another function - AL_LiveSort_1D() - which takes a source range as an argument. So, if you want to specify the source, just use AL_LiveSort_1D() directly instead of AL_Autosort_1D().

The method used to do the "Buddy" part of the routine is a useful technique which could be used by any function to automatically take into account the location and dimensions of the range from which a function is called.

For the sort routine I borrowed VERY heavily from some code posted here by segmentationfault in thread707-332263. I've modified it a bit to handle arrays with non-zero indices, and to speed it up a bit, but it's pretty much his code.
I have not accurately timed how long this takes, but with 5000 cells, the calculation time on my old, steam-driven 750 MHz machine at home, with virtually no free RAM, is significantly less than a second - I'd guess about .3s?
Any way, here is the code. Paste all of this into a module. To use AL_Autosort_1D(), select a single-column or single-row range of cells next to the data you want a sorted version of. In the selected cells, put: "=AL_Autosort()" and press ctrl+shift+enter. That's it.

'The user functions
Public Function AL_AutoSort_1D(Optional HiToLow As Variant = False) As Variant
'This function must be called as an array function.
'It must be called from a 1D array of cells.
'
'It automatically returns a sorted 
'version of the 1D array to the left
'(if this is written to a column) or 
'above (if this is written to a row) of
'the 1D array in which this function is written.

Dim op As Range, data As Range
Dim oprows As Long, opcols As Long, opitems As Long
Dim opcol As Long, oprow As Long
Dim opsht As String
Dim opbook As Workbook
On Error Resume Next

'get the details of the array which called the function
Set op = CallingArray()
oprows = op.Rows.count
opcols = op.Columns.count
opcol = op.Column
oprow = op.row
opsht = op.Worksheet.Name
Set opbook = op.Worksheet.Parent
opitems = op.count

'ensure we are writing to a 1D array
If getmin(oprows, opcols) = 1 Then
    'get the adjacent data
    If oprows > opcols Then
        If op.Column > 1 Then
            With opbook.Worksheets(opsht)
                Set data = .Range(.Cells(oprow, opcol - 1), .Cells(oprow + oprows - 1, opcol - 1))
            End With
        Else
            AL_AutoSort_1D = "No range to left of selected output range"
        End If
    Else
        If op.row > 1 Then
            With opbook.Worksheets(opsht)
                Set data = .Range(.Cells(oprow - 1, opcol), .Cells(oprow - 1, opcol + opcols - 1))
            End With
        Else
            AL_AutoSort_1D = "No range above selected output range"
        End If
    End If
Else
    AL_AutoSort_1D = "Function only valid for a 1D range"
End If

'assuming no errors...
If Err.Number = 0 Then
    'do the sort
    If data.count > 0 Then
        AL_AutoSort_1D = AL_LiveSort_1D(data, HiToLow)
    End If
Else
    Err.Clear
End If
End Function


Public Function AL_LiveSort_1D(data As Range, _
                               Optional HiToLow As Variant = False) _
                               As Variant
'To be used purely as an array formula.
'This function return a 1D array consisting of the
'sorted version of the input data,
'which itself must be a 1D array.
'Note: the output array into which this function
'writes does not have to be the same size as the input array.
'If it is smaller, the sorted values are returned
'up to the size of the output array.  If
'it is larger, the returned array is
'limited to the size of the input array.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim datacols As Long, datarows As Long, numofitems As Long, numofopitems As Long
Dim oprows As Long, opcols As Long
Dim op As Variant, opv As Variant
Dim i As Long, vlb As Long, lb As Long, opshift As Long

'dims of the source data?
datacols = data.Columns.count
datarows = data.Rows.count

'dims of the output range?
If CalledByArray Then
    oprows = CallingArrayRows
    opcols = CallingArrayCols
Else
    oprows = 1
    opcols = 1
End If
If getmin(oprows, opcols) <> 1 Then
    AL_LiveSort_1D = "Error.  Output must be 1D array"
    Exit Function
End If

'ensure source is 1D
If getmin(datacols, datarows) <> 1 Then
    AL_LiveSort_1D = "Error.  Source must be 1D array"
Else
    'put the source data into a 1 d array for use in the sort routine
    numofitems = data.Cells.count
    ReDim ary1d(1 To numofitems) As Variant
    For i = 1 To numofitems
        ary1d(i) = data(i)
    Next i
    
    'sort the array into another 1D array
    op = MergeSort(ary1d)
    
    'put the sorted array data into an array correctly
    'oriented and dimensioned to write directly to the output range
    ReDim opv(1 To oprows, 1 To opcols)
    vlb = LBound(opv)
    numofopitems = getmin(numofitems, getmax(opcols, oprows))
    lb = LBound(op)
    opshift = lb - vlb
    If HiToLow Then
        'data is required in reverse order so reverse it
        opshift = 1 + numofitems + opshift
        If oprows > opcols Then
            For i = vlb To numofopitems + vlb - 1
                opv(i, 1) = op(opshift - i)
            Next i
        Else
            For i = vlb To numofopitems + vlb - 1
                opv(1, i) = op(opshift - i)
            Next i
        End If
    Else
        'data is required the right way round so just copy it
        If oprows > opcols Then
            For i = vlb To numofopitems + vlb - 1
                opv(i, 1) = op(i + opshift)
            Next i
        Else
            For i = vlb To numofopitems + vlb - 1
                opv(1, i) = op(i + opshift)
            Next i
        End If
    End If
    
    'output the data in a suitable format for use by a range
    AL_LiveSort_1D = opv
End If
End Function

'The sorting routines

Function MergeSort(data As Variant)
    ' This delegates the task of sorting
    ' two half sized arrays to copies of
    ' itself, and finally to the
    ' BubbleSort when the array is
    ' sufficiently small.

    Dim sorted

    ' Note that this comparison is the
    ' tradeoff between performance and
    ' memory.  Higher numbers will save
    ' memory at the cost of speed.
    If UBound(data) <= 10 Then
        sorted = BubbleSort(data)
    Else
        Dim lhs As Long
        Dim rhs As Long, lbd As Long, ubd As Long
        lbd = LBound(data)
        ubd = UBound(data)
        lhs = Int((ubd - lbd) / 2)
        rhs = ubd - lbd - lhs - 1
        ReDim lhsdata(lhs) As Variant
        ReDim rhsdata(rhs) As Variant
        Dim i As Long
        For i = 0 To lhs
            lhsdata(i) = data(i + lbd)
        Next i
        For i = 0 To rhs
            rhsdata(i) = data(1 + lhs + i + lbd)
        Next i
        Dim lhsSorted As Variant
        Dim rhsSorted As Variant
        lhsSorted = MergeSort(lhsdata)
        rhsSorted = MergeSort(rhsdata)
        sorted = Merge(lhsSorted, rhsSorted)
    End If
    MergeSort = sorted
End Function

Function Merge(data1 As Variant, Data2 As Variant)
    ' This assembles two sorted array into
    ' a single sorted array
    Dim i As Long
    Dim j As Long
    Dim k As Long
    i = 0
    j = 0
    k = 0
    ReDim SortedData(UBound(data1) + UBound(Data2) + 1)
    Dim klim As Long, ilim As Long, jlim As Long
    klim = UBound(SortedData)
    ilim = 1 + UBound(data1)
    jlim = 1 + UBound(Data2)
    For k = 0 To klim
        If i < ilim And j < jlim Then
            If data1(i) < Data2(j) Then
                SortedData(k) = data1(i)
                i = i + 1
            Else
                SortedData(k) = Data2(j)
                j = j + 1
            End If
        ElseIf i < ilim Then
            SortedData(k) = data1(i)
            i = i + 1
        ElseIf j < jlim Then
            SortedData(k) = Data2(j)
            j = j + 1
        End If
    Next k
    Merge = SortedData
End Function

Function BubbleSort(data As Variant)
    ' This does the actual sorting but is
    ' only executed on small arrays
    Dim Temp As Variant
    Dim i As Long
    Dim j As Long
    Dim lbd As Long, ubd As Long
    lbd = LBound(data)
    ubd = UBound(data)
    For i = lbd + 1 To ubd
        If data(i - 1) > data(i) Then
            j = i
            While j > lbd
                If data(j - 1) > data(j) Then
                    Temp = data(j)
                    data(j) = data(j - 1)
                    data(j - 1) = Temp
                Else
                    j = lbd
                End If
                j = j - 1
            Wend
        End If
    Next i

    BubbleSort = data
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Functions returning data about the calling range

Public Function CalledByArray() As Boolean
'This function indicates whether the cell from which it was called was a single cell or
'part of an array (as in the use of array formulae).

If TypeName(Application.Caller) = "Range" Then
    CalledByArray = Application.Caller.Cells.count > 1
Else
    CalledByArray = False
End If
End Function

Public Function CallingArrayRows()
'This function returns the number of rows in the array from which it was called.
'If it was not called by an array formula, it returns zero.
If TypeName(Application.Caller) = "Range" Then
    Dim rng As Range
    Set rng = Application.Caller
    If rng.Cells.count > 1 Then
        CallingArrayRows = rng.Rows.count
    Else
        CallingArrayRows = 0
    End If
Else
    CallingArrayRows = 0
End If
End Function

Public Function CallingArrayCols()
'This function returns the number of Cols in the array from which it was called.
'If it was not called by an array formula, it returns zero.

If TypeName(Application.Caller) = "Range" Then
    Dim rng As Range
    Set rng = Application.Caller
    If rng.Cells.count > 1 Then
        CallingArrayCols = rng.Columns.count
    Else
        CallingArrayCols = 0
    End If
Else
    CallingArrayCols = 0
End If

End Function

Public Function CallingArray() As Range
'This function returns the number of Cols in the array from which it was called.
'If it was not called by an array formula, it returns zero.

If TypeName(Application.Caller) = "Range" Then
    Set CallingArray = Application.Caller
Else
    Set CallingArray = Nothing
End If

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'General Functions
Public Function getmax(ParamArray data() As Variant) As Variant
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Description:
'This function finds the maximum of an array of inputs.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim maxval As Variant
Dim Index As Integer

Dim X As Variant

maxval = -1.79769313486231E+308
For Each X In data
    If X > maxval Then
        maxval = X
        getmax = X
    End If
Next X
End Function

Public Function getmin(ParamArray data() As Variant) As Variant
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Description:
'This function find the minimum of an array of inputs.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim minval As Variant
Dim Index As Integer
Dim X As Variant

minval = 1.79769313486231E+308
For Each X In data
    If X < minval Then
        minval = X
        getmin = X
    End If
Next X
End Function

I think I included in there everything needed, but if anyone tries to run this and it calls for routines which are not listed, let me know & I'll post them.

Enjoy.
Tony

 

[MeGustaXL]

Hi Tony,

I haven't timed either, but is your code faster than using SMALL()?

If you have data in cells A1 to A1200, Put this formula in B1:

=SMALL($A$1:$A$1200,ROW())

Of course, if you want to sort in descending order, use LARGE in place of SMALL.

Autofill it down, and it sorts the data as it changes, like if you fill column A with "-RAND()" and press F9 repeatedly.

I use this method in my spreadsheets when I want the User's input sorted for charting, etc.

Chris

If yer see a Rook on 'is own, im's a Crow. If yer sees a flock o' Crows, them's Rooks - My Uncle Cecil

 

[N1GHTEYES]

It is a lot faster than Small() (see next paragraph), but I have to be honest and say I'd not come across Small() and Large() before. I thought I was fairly well acquainted with worksheet functions, but, until now, I either did sorting using an arcane routine with a combination of rank and index, or by using an array formula to give the smallest value in a set which was greater than the previous value in the list. The latter method only works if you have no repeat values. I can't help thinking that it would help if the "Help" had a listing for "Sorting Data" which pointed to these functions, but you can't expect the help files to actually be helpful can you?

HOWEVER, to answer your question, erm... yes. It is faster. A LOT faster. About 170 times faster in fact. On my machine, with 5000 points it takes ~47s using Small(), and ~0.28s using either of the routines above (AL_AutoSort_1D() or AL_LiveSort_1D()).

The reason this is so much faster than the inbuilt routine is pretty obvious - it is doing it only once, because it is entered as an array formula, whereas using the Small() routine, the whole set of input data is sorted to provide the answer for every cell.

Still, I definitely experienced another DOH! moment when I read your post. The way this thread is going I could start my own bread factory. Somebody is probably about to point out how to use Small() in an array formula too, thus completely removing the last shread of usefulnes from the routines I spent several hours getting running (yes, I do code slowly).

The reason I was playing around with this in the first place is that I recently came across the Application.Caller method and I can't help thinking it ought to provide a lot of interesting capability I had not previously considered. I guess I'm still exploring those "new" (to me) options.

Anyway, thanks for the info.

Tony

 

[stevexff]

I see you are using quite a complex sort routine, combining bubble sorts and merges. Quicksort is generally reckoned to be the fastest in-memory sort you can do. Might be worth trying it? See

http://www.vba-programmer.com/Snippets/Code_Word/QuickSort_Single_Dimension.html

for an example.

Steve

[small]"Every program can be reduced by one instruction, and every program has at least one bug. Therefore, any program can be reduced to one instruction which doesn't work." (Object:erlDesignPatterns)[/small]

 

[N1GHTEYES]

Thanks Steve. I have a quicksort routine knocking around at work, but I've been at home for the past few days, and the mergesort routine was easily available from an old post.

I've now substituted the sort for the one you suggested and the time went from .28s, for 5000 cells, to .17s. Still, even .28s was fairly good for 5000 cells, especially on this old hand-cranked machine, compared to 47s for the inbuilt method.



Tony

 

[MeGustaXL]

Jeeps, that's fast! I don't need that kind of blistering acceleration though, because in my line of work, [most of] the data sets run to a maximum of 50 points, so SMALL() fits the bill (for now).

When I start getting sample sets of 1,000 or more, I might reconsider.

Heck of a lot of code to write 'just out of interest' though Tony!

Chris

If yer see a Rook on 'is own, im's a Crow. If yer sees a flock o' Crows, them's Rooks - My Uncle Cecil

 

[N1GHTEYES]

Actually Chris, a big chunk was the mergesort, which I more or less lifted, and most of the other stuff I already had. But I can get a bit carried away when I have an idea I want to play with. Besides, I was off sick for a couple of days and bored. This stuff about a function knowing info about the range from which it was called is new to me and I'm fascinated by the possibilities.

Is it all very obvious and really old hat to everyone else?


Tony