alfabetical order in array

[Konrad]

I have dinamic array.
All the elements are diffrent.
Question ? how to sort them in alfabetical order.

Of course you can put data into sheet, sort and reload the
array but it takes time so maybe somebody knows better
solutions.

Tks

 

[Tom Ogilvy]

This this post by Keith Willshaw was meant for you:

There's a nice quicksort routine on Stephen Bullen's page

http://www.bmsltd.co.uk/Excel/SBXLPage.asp

Keith

 

[Dave Ring]

QuickSort is usually a fast algorithm, but can degrade to O(N^2)
behavior (i.e., require time proportional to the square of the number of
items sorted) under certain conditions. The QuickSort on Steve Bullen's
page does not contain the optimization (median of three partitioning)
needed to make such misbehavior unlikely. QuickSort is also unstable --
sorting on each field of a record will lose any ordering based on
previous fields.

MergeSort is almost as fast as QuickSort, but is guaranteed always to
sort in O(N log N) time, no matter what. Furthermore, it's stable; if
you sort on field A and then field B, records with the same value of
field B will remain sorted as to field A. Because of its stability and
consistent performance, MergeSort is often used for system sorts. Its
one drawback is the need for an extra array for the merge operations.

The following code will sort an array of variants into ascending order.
It works by dividing the array into short runs, sorting them by
InsertionSort (the most efficient sort for short lists) and then merging
pairs of runs until only a single run is left.

It's long but fast, and less complicated than it looks.

Dave Ring

Sub MergeSort(A())
Dim B(), Length&, nRuns&, Stack() As Long
Dim I&, L&, R&, LP&, RP&, OP&, TMP

Length = UBound(A)
ReDim B(1 To Length)
nRuns = 1

'Divide the array into short runs
While Length > 20
Length = Length / 4
nRuns = nRuns * 4
Wend
ReDim Stack(1 To nRuns)
For I = 1 To nRuns - 1
Stack(I) = 1 + (Length * CDbl(I))
Next I
Stack(nRuns) = Length

'Sort the short runs by InsertionSort
L = 1
For I = 1 To nRuns
R = Stack(I)
For RP = L + 1 To R
TMP = A(RP)
For LP = RP - 1 To L Step -1
If TMP < A(LP) Then A(LP + 1) = A(LP) Else Exit For
Next LP
A(LP + 1) = TMP
Next RP
L = R + 1
Next I

'Merge pairs of runs until only one is left
While nRuns > 1
'Forward merge from array A to auxiliary array B
R = 0
For I = 2 To nRuns Step 2
LP = R + 1
OP = LP
L = Stack(I - 1)
RP = L + 1
R = Stack(I)
Do
If A(LP) <= A(RP) Then
B(OP) = A(LP)
OP = OP + 1
LP = LP + 1
If LP > L Then
Do
B(OP) = A(RP)
OP = OP + 1
RP = RP + 1
Loop Until RP > R
Exit Do
End If
Else
B(OP) = A(RP)
OP = OP + 1
RP = RP + 1
If RP > R Then
Do
B(OP) = A(LP)
OP = OP + 1
LP = LP + 1
Loop Until LP > L
Exit Do
End If
End If
Loop
Stack(I \ 2) = R
Next I
nRuns = nRuns \ 2

'Backward merge from auxiliary array B to A
R = 0
For I = 2 To nRuns Step 2
LP = R + 1
OP = LP
L = Stack(I - 1)
RP = L + 1
R = Stack(I)
Do
If B(LP) <= B(RP) Then
A(OP) = B(LP)
OP = OP + 1
LP = LP + 1
If LP > L Then
Do
A(OP) = B(RP)
OP = OP + 1
RP = RP + 1
Loop Until RP > R
Exit Do
End If
Else
A(OP) = B(RP)
OP = OP + 1
RP = RP + 1
If RP > R Then
Do
A(OP) = B(LP)
OP = OP + 1
LP = LP + 1
Loop Until LP > L
Exit Do
End If
End If
Loop
Stack(I \ 2) = R
Next I
nRuns = nRuns \ 2
Wend
End Sub

 

[Myrna Larson]

And, for others who are interested in seeing how a merge sort works, I've rewritten Dave's
routine, splitting it into 4 separate Subs -- the main one, which calls the other 3. They are
(1) a routine to set up the stack array (I called it Ptrs()), (2) the insertion sort code, and
(3) the code to merge two adjacent segments into one. And I modified things to work with arrays
that have a lower bound other than 1.

As Dave mentioned in our email correspondence, in-line code undoubtedly runs faster than
separate subs, but the latter are easier to decipher.

I changed the array type from variant to double. The consequence of that is you need separate
code for sorting each data type. But I prefer that, because variants are inherently slow to work
with.

Option Explicit

Sub MergeSort(Ary() As Double)
'Based on code from Dave Ring, 08/15/2003, (e-mail address removed)
Dim i As Long
Dim j As Long
Dim NumSegs As Long
Dim Ptrs() As Long
Dim Tmp() As Double

i = LBound(Ary)
j = UBound(Ary)
ReDim Tmp(i To j)

'partition the array into small segments with
'pointers to end of each segment in Ptrs()
NumSegs = MakePtrs(i, j, Ptrs())

'sort each segment with InsertionSort
For i = 1 To NumSegs
InsertionSort Ary(), Ptrs(i - 1) + 1, Ptrs(i)
Next i

'merge pairs of segments until only one is left
Do While NumSegs > 1
For i = 2 To NumSegs Step 2
MergeSegments Ary(), Tmp(), _
Ptrs(i - 2) + 1, Ptrs(i - 1), Ptrs(i - 1) + 1, Ptrs(i)
Ptrs(i \ 2) = Ptrs(i)
Next i
NumSegs = NumSegs \ 2

For i = 2 To NumSegs Step 2
MergeSegments Tmp(), Ary(), _
Ptrs(i - 2) + 1, Ptrs(i - 1), Ptrs(i - 1) + 1, Ptrs(i)
Ptrs(i \ 2) = Ptrs(i)
Next i
NumSegs = NumSegs \ 2
Loop
End Sub

Private Function MakePtrs(Lo As Long, Hi As Long, Ptrs() As Long) As Long
'modified to handle arrays with lower bound <> 1
Dim i As Long
Dim Size As Double
Dim NumSegs As Long
Dim N As Long

Size = Hi - Lo + 1
NumSegs = 1
Do While Size > 20
Size = Size / 4
NumSegs = NumSegs * 4
Loop

'fill array with pointer to last element in each segment
ReDim Ptrs(0 To NumSegs)
Ptrs(0) = Lo - 1
Ptrs(NumSegs) = Hi
For i = 1 To NumSegs - 1
Ptrs(i) = i * Size + Lo - 1
Next i
MakePtrs = NumSegs
End Function

Sub InsertionSort(Ary() As Double, Lo As Long, Hi As Long)
Dim i As Long
Dim j As Long
Dim Tmp As Double

For i = Lo + 1 To Hi
Tmp = Ary(i)
For j = i - 1 To Lo Step -1
If Tmp < Ary(j) Then
Ary(j + 1) = Ary(j)
Else
Exit For
End If
Next j
Ary(j + 1) = Tmp
Next i
End Sub

Private Sub MergeSegments(Src() As Double, Dest() As Double, _
LeftFirst As Long, LeftLast As Long, RightFirst As Long, RightLast As Long)
Dim L As Long
Dim R As Long
Dim p As Long

L = LeftFirst
R = RightFirst
p = L - 1

Do
If Src(L) <= Src(R) Then
p = p + 1
Dest(p) = Src(L)

If L = LeftLast Then
For R = R To RightLast
p = p + 1
Dest(p) = Src(R)
Next R
Exit Do
Else
L = L + 1
End If

Else
p = p + 1
Dest(p) = Src(R)

If R = RightLast Then
For L = L To LeftLast
p = p + 1
Dest(p) = Src(L)
Next L
Exit Do
Else
R = R + 1
End If
End If
Loop
End Sub

 

[Dave Ring]

Since I dusted it off while corresponding with Myrna, here is code for a
RadixSort that is only good for string keys, but more than twice as fast
as my posted MergeSort. Since the time required for radix sorting grows
only linearly, this is one to use if you literally have millions of
strings to sort.

Because it does no comparisons, RadixSort escapes the O(NlogN) limit and
can sort in time proportional to the total char count in your keys.
This is an MSD (most significant digit) RadixSort because it sorts based
on chars from left to right. That's efficient, since only enough chars
are examined to finish sorting, but complex, since each subrun sorted at
the current char depth must be separately sorted at later chars.

Dave Ring

Public Sub MSDRadixSort(LO&, HI&, A$(), P&())
'A() holds string keys, P() holds pointers to them
'LO & HI point to first & last keys
Dim L&, R&, D&, SP&, I&, J&, C$, N&, HiCNT&, OldSP&, HiSP&
Dim LS&(1 To 1000), RS&(1 To 1000), DS&(1 To 1000)
Dim CH&(), CNT&(0 To 256), IND&(0 To 256), Q&()

ReDim CH(LO To HI) 'Array to hold chars at current depth
ReDim Q(LO To HI) 'Auxiliary array for reordering pointers
SP = 1: LS(SP) = LO: RS(SP) = HI: DS(SP) = 1 'Set up stack
While SP > 0 'Pop a run of keys matched at last char
L = LS(SP): R = RS(SP): D = DS(SP): SP = SP - 1
If R - L > 24 Then 'Sort longer runs with RadixSort
For I = L To R
C = Mid$(A(P(I)), D, 1) 'Get char at current depth
If C = "" Then N = 0 Else N = Asc(C) '& its ASCII val
CH(I) = N 'Store chars for this depth in CH()
CNT(N) = CNT(N) + 1 'Increment count of current char
Next I
OldSP = SP 'Save position in stack
HiCNT = 0: HiSP = 0 'Prepare to find longest subrun
IND(0) = L 'Set first address to first key
For J = 0 To MAXCHAR - 1 'Build sorted addresses
I = J + 1: N = CNT(J): CNT(J) = 0 'Fetch then zero count
IND(I) = IND(J) + N 'Address = last address + count
If N > 1 And J > 0 Then 'Save latest subrun on stack
SP = SP + 1: LS(SP) = IND(J): RS(SP) = IND(I) - 1
DS(SP) = D + 1 'Set next char depth
If N > HiCNT Then
HiCNT = N: HiSP = SP 'Save pos of longest run
End If
End If
Next J
N = HiSP: HiSP = OldSP: OldSP = N 'Swap longest run down
'Sorting the longest subrun last limits stack depth
For I = L To R 'Don't blink; next lines do the sorting
C = CH(I) 'The char at depth will generate an address
Q(IND(C)) = P(I) 'Move the key pointer to that address
IND(C) = IND(C) + 1 'And increment the address
Next I
For I = L To R
P(I) = Q(I) 'Move the pointers back to primary array
Next I
Else 'Sort shorter runs with InsertionSort
For I = L + 1 To R
N = P(I)
For J = I - 1 To L Step -1
If A(N) < A(P(J)) Then P(J + 1) = P(J) Else Exit For
Next J
P(J + 1) = N
Next I
End If
Wend
End Sub