Irene said:
I have an array filled with names which i pull from Outlook. The array has
7
columns. How to i sort based on 2 columns, First sort on last name and
then
by age?
I have seen many sort alg. but none with 2 column sort
Thanks,
Hi Irene,
You need some sorting algorithm that's "stable". This means if two records
have the same key, they appear in the same order in the sorted list as they
appear in the original list.
So you can sort first by age, then by last name. If the sort is stable, the
entries with the same last name will still be sorted by age.
I use Mergesort, adapted from this site:
http://www.devx.com/vb2themax/Tip/19470
Option Explicit
' (c)
http://www.devx.com/vb2themax/Tip/19470
' MergeSort. A stable sort (preserves original order of records with equal
' keys). Like HeapSort, easily adapted to any data type and guaranteed to
run
' in O(N log N) time, but almost twice as fast. On the down side,
' needs an extra array of N items, but these can be pointers if the keys
' themselves are larger than pointers. Works by repeatedly merging short
' sorted sequences (created by InsertionSort) into longer ones. Two
versions
' are given. pMergeSortS is an indirect (pointerized) version for strings,
' which can be adapted to doubles by changing the declaration of A().
' MergeSortL is a direct version for longs, which can be adapted to
integers.
'
'
' Bottom line: fast stable sort that easily handles all data types,
' but a heavy memory user.
' Usage:
Public l
Public R
Public ColTot
Sub TestMerge()
Dim i As Long, j As Long
Dim start
l = 0
R = 100000
ColTot = 12
Dim ColNr As Long
ColNr = 1
Dim S1() As Variant
ReDim S1(0 To ColTot, l To R)
For i = l To R
S1(0, i) = i
S1(1, i) = Int(1000 * Rnd())
S1(2, i) = ChrW(AscW("a") + Int(12 * Rnd())) & ChrW(AscW("a") + Int(12 *
Rnd()))
For j = 3 To ColTot
S1(j, i) = GetRandomLong()
Next j
Next i
start = Timer
pMergeSort S1, 3
MsgBox Timer - start
End Sub
' CODE:
Sub pMergeSort(a() As Variant, ColNr As Long)
Dim LBA1 As Long
LBA1 = LBound(a, 1)
Dim UBA1 As Long
UBA1 = UBound(a, 1)
Dim LBA2 As Long
LBA2 = LBound(a, 2)
Dim UBA2 As Long
UBA2 = UBound(a, 2)
Dim i As Long, j As Long
Dim P1() As Long
Dim P2() As Long
Dim B() As Variant
ReDim P1(LBA2 To UBA2)
ReDim P2(LBA2 To UBA2)
For i = LBound(a, 2) To UBound(a, 2)
P1(i) = i
Next i
pMergeSortS LBound(a, 2), UBound(a, 2), a, P1, P2, ColNr
B = a
For i = LBA1 To UBA1
For j = LBA2 To UBA2
a(i, j) = B(i, P1(j))
Next j
Next i
End Sub
Sub pMergeSortS(l As Long, R As Long, a() As Variant, P() As Long, Q() As
Long, ColNr As Long)
Dim LP As Long 'left pointer
Dim RP As Long 'right pointer
Dim OP As Long 'output pointer
Dim MID As Long
'This version is for variants; for other data types,
' change declaration of A().
'MergeSort recursively calls itself until we have lists short enough for
' InsertionSort.
If R - l < 10 Then
'call an indirect (pointerized) version of InsertionSort
pInsertS l, R, a, P, ColNr
Else
'if too long for InsertionSort, split list and recurse
MID = (l + R) \ 2
pMergeSortS l, MID, a, P, Q, ColNr
pMergeSortS MID + 1, R, a, P, Q, ColNr
'Each half of the array is sorted; now we'll merge them into the
extra
' array.
'We'll work via pointers, to keep the extra array smaller.
LP = l
RP = MID + 1
OP = l
Do
'Copy the pointer to the smaller string.
If a(ColNr, P(LP)) <= a(ColNr, P(RP)) Then
Q(OP) = P(LP)
OP = OP + 1
LP = LP + 1
If LP > MID Then
'We ran out of the left half, so transfer the rest of the right
' half.
Do
Q(OP) = P(RP)
OP = OP + 1
RP = RP + 1
Loop Until RP > R
'This merge is done.
Exit Do
End If
Else
'This part is a mirror image of the last part.
Q(OP) = P(RP)
OP = OP + 1
RP = RP + 1
If RP > R Then
Do
Q(OP) = P(LP)
OP = OP + 1
LP = LP + 1
Loop Until LP > MID
Exit Do
End If
End If
Loop
'Finally, we copy the pointers back from the extra array to the main
array.
For OP = l To R
P(OP) = Q(OP)
Next OP
End If
End Sub
Sub pInsertS(l As Long, R As Long, a() As Variant, P() As Long, ColNr As
Long)
Dim LP As Long
Dim RP As Long
Dim TMP As Long
Dim t As Variant
For RP = l + 1 To R
TMP = P(RP)
t = a(ColNr, TMP)
For LP = RP To l + 1 Step -1
If t < a(ColNr, P(LP - 1)) Then P(LP) = P(LP - 1) Else Exit For
Next LP
P(LP) = TMP
Next RP
End Sub
