Re: VBA Sort 2-dimensional array based on 2 column

Tech-Archive recommends: Fix windows errors by optimizing your registry

"Irene" <ienulf@xxxxxxxxxxx> wrote:
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





.

Relevant Pages

  • Re: VBA Sort 2-dimensional array based on 2 column
    ... The column number to sort by is the second argument, ColNr, in the code I ... My array has 10 columns. ... Dim i As Long, j As Long ...
    (microsoft.public.office.developer.vba)
  • Re: obscure array sort
    ... You are asking for a sort that takes groups of 4 elements ... in an array and sorts them in isolation to the rest of the array. ... Public Function SortInGroups(ArrayToSort As Variant, ... Dim aryToSort As Variant ...
    (microsoft.public.excel.programming)
  • Re: Make Table Query - Sorting Errors
    ... Dim OutputTable As DAO.Recordset ... The query to concatenate the CAMPNO values will need to be LOOKING at the ... If you post the query you are using to do this, I beleive we can get it to ... Is there a command that I can use in the module code to first sort the ...
    (microsoft.public.access.queries)
  • Re: VBA Sort 2-dimensional array based on 2 column
    ... I pull all of the data into an array then I ... Some of the fields are blank, can that mess up the sort? ... Dim i As Long, j As Long ... 'MergeSort recursively calls itself until we have lists short enough ...
    (microsoft.public.office.developer.vba)
  • Re: VBA Sort 2-dimensional array based on 2 column
    ... a simple bubble sort should work fine. ... If your array is named myArray, and you want to sort by column 5 (say age ... Dim i As Long, j As Long ... Dim ColNr As Long ...
    (microsoft.public.office.developer.vba)