alfabetical order in array
 

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

alfabetical order in array
 

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

--
Regards,
Tom Ogilvy

"Konrad" wrote in message
...
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

alfabetical order in array
 

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

Konrad wrote:
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

alfabetical order in array
 

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,
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