Fastest way to sort large 2-D arrays?

[RB Smissaert]

In my application I often have to sort large 2-D arrays.
I have found a routine for this that works quite fast, but thought
maybe it could be made faster by making a dll via a COM add-in
compiled in Office Developer. This was quite easy to do with the
example on Chip Pearson's website.
Unfortunately it turns out that sorting the array with this dll is about
8 to 9 times slower.
Would there be any way to do this faster? The arrays are often too big
for the worksheet, so sorting in the sheet won't work.

Below the routine I downloaded. Not sure who wrote it:

Sub procSort2D(ByRef avArray, _
ByVal sOrder As String, _
ByVal iKey As Long, _
Optional ByVal iLow1 As Long = -1, _
Optional ByVal iHigh1 As Long = -1)

On Error GoTo ERROROUT

Dim iLow2 As Long
Dim iHigh2 As Long
Dim i As Long
Dim vItem1 As Variant
Dim vItem2 As Variant

If iLow1 = -1 Then
iLow1 = LBound(avArray, 1)
End If

If iHigh1 = -1 Then
iHigh1 = UBound(avArray, 1)
End If

'Set new extremes to old extremes
iLow2 = iLow1
iHigh2 = iHigh1

'Get value of array item in middle of new extremes
vItem1 = avArray((iLow1 + iHigh1) \ 2, iKey)

'Loop for all the items in the array between the extremes
While iLow2 < iHigh2

If sOrder = "A" Then
'Find the first item that is greater than the mid-point item
While avArray(iLow2, iKey) < vItem1 And iLow2 < iHigh1
iLow2 = iLow2 + 1
Wend

'Find the last item that is less than the mid-point item
While avArray(iHigh2, iKey) > vItem1 And iHigh2 > iLow1
iHigh2 = iHigh2 - 1
Wend
Else
'Find the first item that is less than the mid-point item
While avArray(iLow2, iKey) > vItem1 And iLow2 < iHigh1
iLow2 = iLow2 + 1
Wend

'Find the last item that is greater than the mid-point item
While avArray(iHigh2, iKey) < vItem1 And iHigh2 > iLow1
iHigh2 = iHigh2 - 1
Wend
End If

'If the two items are in the wrong order, swap the rows
If iLow2 < iHigh2 Then
For i = LBound(avArray) To UBound(avArray, 2)
vItem2 = avArray(iLow2, i)
avArray(iLow2, i) = avArray(iHigh2, i)
avArray(iHigh2, i) = vItem2
Next
End If

'If the pointers are not together, advance to the next item
If iLow2 <= iHigh2 Then
iLow2 = iLow2 + 1
iHigh2 = iHigh2 - 1
End If
Wend

'Recurse to sort the lower half of the extremes
If iHigh2 > iLow1 Then procSort2D avArray, sOrder, iKey, iLow1, iHigh2

'Recurse to sort the upper half of the extremes
If iLow2 < iHigh1 Then procSort2D avArray, sOrder, iKey, iLow2, iHigh1

Exit Sub
ERROROUT:

MsgBox "There was an error while sorting a 2-D array" & _
vbCrLf & _
"___________________________________" & _
vbCrLf & vbCrLf & _
"most likely there wasn't enough memory" & _
vbCrLf & _
"the size of this array was" & _
vbCrLf & _
"rows: " & vbTab & UBound(avArray) & _
vbCrLf & _
"columns: " & vbTab & UBound(avArray, 2) & _
vbCrLf & vbCrLf & _
"VBA error" & _
vbCrLf & _
"source: " & vbTab & Err.Source & _
vbCrLf & _
"number: " & vbTab & Err.Number & _
vbCrLf & _
"description:" & vbTab & Err.Description, , ""

End Sub


Thanks for any advice.


RBS

[Fredrik Wahlgren]

"RB Smissaert" <[email protected]> wrote in message
news:[email protected]...
> In my application I often have to sort large 2-D arrays.
> I have found a routine for this that works quite fast, but thought
> maybe it could be made faster by making a dll via a COM add-in
> compiled in Office Developer. This was quite easy to do with the
> example on Chip Pearson's website.
> Unfortunately it turns out that sorting the array with this dll is about
> 8 to 9 times slower.
> Would there be any way to do this faster? The arrays are often too big
> for the worksheet, so sorting in the sheet won't work.
>
> Below the routine I downloaded. Not sure who wrote it:
>
>Truncated

I don't think you can create COM add-ins with Office Developer. I think you
need VB6 or later.A compiled add-in would be much faster than what you can
do with VBA.

/Fredrik

[Chip Pearson]

> I don't think you can create COM add-ins with Office Developer.

Yes, you can. In the VBA Editor, choose New Project from the File
menu.


--
Cordially,
Chip Pearson
Microsoft MVP - Excel
Pearson Software Consulting, LLC
www.cpearson.com



"Fredrik Wahlgren" <[email protected]> wrote
in message news:[email protected]...
>
> "RB Smissaert" <[email protected]> wrote in
> message
> news:[email protected]...
>> In my application I often have to sort large 2-D arrays.
>> I have found a routine for this that works quite fast, but
>> thought
>> maybe it could be made faster by making a dll via a COM add-in
>> compiled in Office Developer. This was quite easy to do with
>> the
>> example on Chip Pearson's website.
>> Unfortunately it turns out that sorting the array with this
>> dll is about
>> 8 to 9 times slower.
>> Would there be any way to do this faster? The arrays are often
>> too big
>> for the worksheet, so sorting in the sheet won't work.
>>
>> Below the routine I downloaded. Not sure who wrote it:
>>
>>Truncated
>
> I don't think you can create COM add-ins with Office Developer.
> I think you
> need VB6 or later.A compiled add-in would be much faster than
> what you can
> do with VBA.
>
> /Fredrik
>
>

[RB Smissaert]

Well, you definitely can do that as I have just done it!
The test workbook is also definitely using the the dll as
there is no code whatsoever in the workbook to sort the array.
If you want to see it for your self I can send you the dll and the test
..xls file.

RBS


"Fredrik Wahlgren" <[email protected]> wrote in message
news:[email protected]...
>
> "RB Smissaert" <[email protected]> wrote in message
> news:[email protected]...
>> In my application I often have to sort large 2-D arrays.
>> I have found a routine for this that works quite fast, but thought
>> maybe it could be made faster by making a dll via a COM add-in
>> compiled in Office Developer. This was quite easy to do with the
>> example on Chip Pearson's website.
>> Unfortunately it turns out that sorting the array with this dll is about
>> 8 to 9 times slower.
>> Would there be any way to do this faster? The arrays are often too big
>> for the worksheet, so sorting in the sheet won't work.
>>
>> Below the routine I downloaded. Not sure who wrote it:
>>
>>Truncated
>
> I don't think you can create COM add-ins with Office Developer. I think
> you
> need VB6 or later.A compiled add-in would be much faster than what you can
> do with VBA.
>
> /Fredrik
>
>

[Daniel.M]

Hi,

Use Laurent Longre's VSORT (or VSORT.IDX) function available in his MOREFUNC.XLL
It's built in 'C' (using pointers for swapping elements) so it's quite fast.

Once installed, it can be invoked in VBA as in:
Dim V As Variant
V = Application.Run([VSORT], Range("A1:B20"), 1)

Regards,

Daniel M.

"RB Smissaert" <[email protected]> wrote in message
news:[email protected]...
> In my application I often have to sort large 2-D arrays.
> I have found a routine for this that works quite fast, but thought
> maybe it could be made faster by making a dll via a COM add-in
> compiled in Office Developer. This was quite easy to do with the
> example on Chip Pearson's website.
> Unfortunately it turns out that sorting the array with this dll is about
> 8 to 9 times slower.
> Would there be any way to do this faster? The arrays are often too big
> for the worksheet, so sorting in the sheet won't work.
>
> Below the routine I downloaded. Not sure who wrote it:
>
> Sub procSort2D(ByRef avArray, _
> ByVal sOrder As String, _
> ByVal iKey As Long, _
> Optional ByVal iLow1 As Long = -1, _
> Optional ByVal iHigh1 As Long = -1)
>
> On Error GoTo ERROROUT
>
> Dim iLow2 As Long
> Dim iHigh2 As Long
> Dim i As Long
> Dim vItem1 As Variant
> Dim vItem2 As Variant
>
> If iLow1 = -1 Then
> iLow1 = LBound(avArray, 1)
> End If
>
> If iHigh1 = -1 Then
> iHigh1 = UBound(avArray, 1)
> End If
>
> 'Set new extremes to old extremes
> iLow2 = iLow1
> iHigh2 = iHigh1
>
> 'Get value of array item in middle of new extremes
> vItem1 = avArray((iLow1 + iHigh1) \ 2, iKey)
>
> 'Loop for all the items in the array between the extremes
> While iLow2 < iHigh2
>
> If sOrder = "A" Then
> 'Find the first item that is greater than the mid-point item
> While avArray(iLow2, iKey) < vItem1 And iLow2 < iHigh1
> iLow2 = iLow2 + 1
> Wend
>
> 'Find the last item that is less than the mid-point item
> While avArray(iHigh2, iKey) > vItem1 And iHigh2 > iLow1
> iHigh2 = iHigh2 - 1
> Wend
> Else
> 'Find the first item that is less than the mid-point item
> While avArray(iLow2, iKey) > vItem1 And iLow2 < iHigh1
> iLow2 = iLow2 + 1
> Wend
>
> 'Find the last item that is greater than the mid-point item
> While avArray(iHigh2, iKey) < vItem1 And iHigh2 > iLow1
> iHigh2 = iHigh2 - 1
> Wend
> End If
>
> 'If the two items are in the wrong order, swap the rows
> If iLow2 < iHigh2 Then
> For i = LBound(avArray) To UBound(avArray, 2)
> vItem2 = avArray(iLow2, i)
> avArray(iLow2, i) = avArray(iHigh2, i)
> avArray(iHigh2, i) = vItem2
> Next
> End If
>
> 'If the pointers are not together, advance to the next item
> If iLow2 <= iHigh2 Then
> iLow2 = iLow2 + 1
> iHigh2 = iHigh2 - 1
> End If
> Wend
>
> 'Recurse to sort the lower half of the extremes
> If iHigh2 > iLow1 Then procSort2D avArray, sOrder, iKey, iLow1, iHigh2
>
> 'Recurse to sort the upper half of the extremes
> If iLow2 < iHigh1 Then procSort2D avArray, sOrder, iKey, iLow2, iHigh1
>
> Exit Sub
> ERROROUT:
>
> MsgBox "There was an error while sorting a 2-D array" & _
> vbCrLf & _
> "___________________________________" & _
> vbCrLf & vbCrLf & _
> "most likely there wasn't enough memory" & _
> vbCrLf & _
> "the size of this array was" & _
> vbCrLf & _
> "rows: " & vbTab & UBound(avArray) & _
> vbCrLf & _
> "columns: " & vbTab & UBound(avArray, 2) & _
> vbCrLf & vbCrLf & _
> "VBA error" & _
> vbCrLf & _
> "source: " & vbTab & Err.Source & _
> vbCrLf & _
> "number: " & vbTab & Err.Number & _
> vbCrLf & _
> "description:" & vbTab & Err.Description, , ""
>
> End Sub
>
>
> Thanks for any advice.
>
>
> RBS
>

[Tim Williams]

You could try loading your data into an ADO recordset and sorting it
there.
Google for "disconnected recordset" and ADO

Tim



"RB Smissaert" <[email protected]> wrote in message
news:[email protected]...
> In my application I often have to sort large 2-D arrays.
> I have found a routine for this that works quite fast, but thought
> maybe it could be made faster by making a dll via a COM add-in
> compiled in Office Developer. This was quite easy to do with the
> example on Chip Pearson's website.
> Unfortunately it turns out that sorting the array with this dll is
> about
> 8 to 9 times slower.
> Would there be any way to do this faster? The arrays are often too
> big
> for the worksheet, so sorting in the sheet won't work.
>
> Below the routine I downloaded. Not sure who wrote it:
>
> Sub procSort2D(ByRef avArray, _
> ByVal sOrder As String, _
> ByVal iKey As Long, _
> Optional ByVal iLow1 As Long = -1, _
> Optional ByVal iHigh1 As Long = -1)
>
> On Error GoTo ERROROUT
>
> Dim iLow2 As Long
> Dim iHigh2 As Long
> Dim i As Long
> Dim vItem1 As Variant
> Dim vItem2 As Variant
>
> If iLow1 = -1 Then
> iLow1 = LBound(avArray, 1)
> End If
>
> If iHigh1 = -1 Then
> iHigh1 = UBound(avArray, 1)
> End If
>
> 'Set new extremes to old extremes
> iLow2 = iLow1
> iHigh2 = iHigh1
>
> 'Get value of array item in middle of new extremes
> vItem1 = avArray((iLow1 + iHigh1) \ 2, iKey)
>
> 'Loop for all the items in the array between the extremes
> While iLow2 < iHigh2
>
> If sOrder = "A" Then
> 'Find the first item that is greater than the mid-point
> item
> While avArray(iLow2, iKey) < vItem1 And iLow2 < iHigh1
> iLow2 = iLow2 + 1
> Wend
>
> 'Find the last item that is less than the mid-point item
> While avArray(iHigh2, iKey) > vItem1 And iHigh2 > iLow1
> iHigh2 = iHigh2 - 1
> Wend
> Else
> 'Find the first item that is less than the mid-point item
> While avArray(iLow2, iKey) > vItem1 And iLow2 < iHigh1
> iLow2 = iLow2 + 1
> Wend
>
> 'Find the last item that is greater than the mid-point
> item
> While avArray(iHigh2, iKey) < vItem1 And iHigh2 > iLow1
> iHigh2 = iHigh2 - 1
> Wend
> End If
>
> 'If the two items are in the wrong order, swap the rows
> If iLow2 < iHigh2 Then
> For i = LBound(avArray) To UBound(avArray, 2)
> vItem2 = avArray(iLow2, i)
> avArray(iLow2, i) = avArray(iHigh2, i)
> avArray(iHigh2, i) = vItem2
> Next
> End If
>
> 'If the pointers are not together, advance to the next item
> If iLow2 <= iHigh2 Then
> iLow2 = iLow2 + 1
> iHigh2 = iHigh2 - 1
> End If
> Wend
> 'Recurse to sort the lower half of the extremes
> If iHigh2 > iLow1 Then procSort2D avArray, sOrder, iKey, iLow1,
> iHigh2
>
> 'Recurse to sort the upper half of the extremes
> If iLow2 < iHigh1 Then procSort2D avArray, sOrder, iKey, iLow2,
> iHigh1
>
> Exit Sub
> ERROROUT:
>
> MsgBox "There was an error while sorting a 2-D array" & _
> vbCrLf & _
> "___________________________________" & _
> vbCrLf & vbCrLf & _
> "most likely there wasn't enough memory" & _
> vbCrLf & _
> "the size of this array was" & _
> vbCrLf & _
> "rows: " & vbTab & UBound(avArray) & _
> vbCrLf & _
> "columns: " & vbTab & UBound(avArray, 2) & _
> vbCrLf & vbCrLf & _
> "VBA error" & _
> vbCrLf & _
> "source: " & vbTab & Err.Source & _
> vbCrLf & _
> "number: " & vbTab & Err.Number & _
> vbCrLf & _
> "description:" & vbTab & Err.Description, , ""
>
> End Sub
>
>
> Thanks for any advice.
>
>
> RBS
>

[Norman Jones]

Hi RB,

> Below the routine I downloaded. Not sure who wrote it:

I believe that the Sub procSort2D routine would have been downloaded as part
of Stephen Bullen's QuickSort demo.


You have reponses to the substantive question, but I shall watch the thread
with interest.


---
Regards,
Norman



"RB Smissaert" <[email protected]> wrote in message
news:[email protected]...
> In my application I often have to sort large 2-D arrays.
> I have found a routine for this that works quite fast, but thought
> maybe it could be made faster by making a dll via a COM add-in
> compiled in Office Developer. This was quite easy to do with the
> example on Chip Pearson's website.
> Unfortunately it turns out that sorting the array with this dll is about
> 8 to 9 times slower.
> Would there be any way to do this faster? The arrays are often too big
> for the worksheet, so sorting in the sheet won't work.
>
> Below the routine I downloaded. Not sure who wrote it:
>
> Sub procSort2D(ByRef avArray, _
> ByVal sOrder As String, _
> ByVal iKey As Long, _
> Optional ByVal iLow1 As Long = -1, _
> Optional ByVal iHigh1 As Long = -1)
>
> On Error GoTo ERROROUT
>
> Dim iLow2 As Long
> Dim iHigh2 As Long
> Dim i As Long
> Dim vItem1 As Variant
> Dim vItem2 As Variant
>
> If iLow1 = -1 Then
> iLow1 = LBound(avArray, 1)
> End If
>
> If iHigh1 = -1 Then
> iHigh1 = UBound(avArray, 1)
> End If
>
> 'Set new extremes to old extremes
> iLow2 = iLow1
> iHigh2 = iHigh1
>
> 'Get value of array item in middle of new extremes
> vItem1 = avArray((iLow1 + iHigh1) \ 2, iKey)
>
> 'Loop for all the items in the array between the extremes
> While iLow2 < iHigh2
>
> If sOrder = "A" Then
> 'Find the first item that is greater than the mid-point item
> While avArray(iLow2, iKey) < vItem1 And iLow2 < iHigh1
> iLow2 = iLow2 + 1
> Wend
>
> 'Find the last item that is less than the mid-point item
> While avArray(iHigh2, iKey) > vItem1 And iHigh2 > iLow1
> iHigh2 = iHigh2 - 1
> Wend
> Else
> 'Find the first item that is less than the mid-point item
> While avArray(iLow2, iKey) > vItem1 And iLow2 < iHigh1
> iLow2 = iLow2 + 1
> Wend
>
> 'Find the last item that is greater than the mid-point item
> While avArray(iHigh2, iKey) < vItem1 And iHigh2 > iLow1
> iHigh2 = iHigh2 - 1
> Wend
> End If
>
> 'If the two items are in the wrong order, swap the rows
> If iLow2 < iHigh2 Then
> For i = LBound(avArray) To UBound(avArray, 2)
> vItem2 = avArray(iLow2, i)
> avArray(iLow2, i) = avArray(iHigh2, i)
> avArray(iHigh2, i) = vItem2
> Next
> End If
>
> 'If the pointers are not together, advance to the next item
> If iLow2 <= iHigh2 Then
> iLow2 = iLow2 + 1
> iHigh2 = iHigh2 - 1
> End If
> Wend
> 'Recurse to sort the lower half of the extremes
> If iHigh2 > iLow1 Then procSort2D avArray, sOrder, iKey, iLow1, iHigh2
>
> 'Recurse to sort the upper half of the extremes
> If iLow2 < iHigh1 Then procSort2D avArray, sOrder, iKey, iLow2, iHigh1
>
> Exit Sub
> ERROROUT:
>
> MsgBox "There was an error while sorting a 2-D array" & _
> vbCrLf & _
> "___________________________________" & _
> vbCrLf & vbCrLf & _
> "most likely there wasn't enough memory" & _
> vbCrLf & _
> "the size of this array was" & _
> vbCrLf & _
> "rows: " & vbTab & UBound(avArray) & _
> vbCrLf & _
> "columns: " & vbTab & UBound(avArray, 2) & _
> vbCrLf & vbCrLf & _
> "VBA error" & _
> vbCrLf & _
> "source: " & vbTab & Err.Source & _
> vbCrLf & _
> "number: " & vbTab & Err.Number & _
> vbCrLf & _
> "description:" & vbTab & Err.Description, , ""
>
> End Sub
>
>
> Thanks for any advice.
>
>
> RBS
>

[RB Smissaert]

Thanks, will have a look at that.
Your example mentions a range.
Is this a range in the sheet?
My arrays are VBA arrays, would it
work with that?

RBS

"Daniel.M" <[email protected]> wrote in message
news:%[email protected]...
> Hi,
>
> Use Laurent Longre's VSORT (or VSORT.IDX) function available in his
> MOREFUNC.XLL
> It's built in 'C' (using pointers for swapping elements) so it's quite
> fast.
>
> Once installed, it can be invoked in VBA as in:
> Dim V As Variant
> V = Application.Run([VSORT], Range("A1:B20"), 1)
>
> Regards,
>
> Daniel M.
>
> "RB Smissaert" <[email protected]> wrote in message
> news:[email protected]...
>> In my application I often have to sort large 2-D arrays.
>> I have found a routine for this that works quite fast, but thought
>> maybe it could be made faster by making a dll via a COM add-in
>> compiled in Office Developer. This was quite easy to do with the
>> example on Chip Pearson's website.
>> Unfortunately it turns out that sorting the array with this dll is about
>> 8 to 9 times slower.
>> Would there be any way to do this faster? The arrays are often too big
>> for the worksheet, so sorting in the sheet won't work.
>>
>> Below the routine I downloaded. Not sure who wrote it:
>>
>> Sub procSort2D(ByRef avArray, _
>> ByVal sOrder As String, _
>> ByVal iKey As Long, _
>> Optional ByVal iLow1 As Long = -1, _
>> Optional ByVal iHigh1 As Long = -1)
>>
>> On Error GoTo ERROROUT
>>
>> Dim iLow2 As Long
>> Dim iHigh2 As Long
>> Dim i As Long
>> Dim vItem1 As Variant
>> Dim vItem2 As Variant
>>
>> If iLow1 = -1 Then
>> iLow1 = LBound(avArray, 1)
>> End If
>>
>> If iHigh1 = -1 Then
>> iHigh1 = UBound(avArray, 1)
>> End If
>>
>> 'Set new extremes to old extremes
>> iLow2 = iLow1
>> iHigh2 = iHigh1
>>
>> 'Get value of array item in middle of new extremes
>> vItem1 = avArray((iLow1 + iHigh1) \ 2, iKey)
>>
>> 'Loop for all the items in the array between the extremes
>> While iLow2 < iHigh2
>>
>> If sOrder = "A" Then
>> 'Find the first item that is greater than the mid-point item
>> While avArray(iLow2, iKey) < vItem1 And iLow2 < iHigh1
>> iLow2 = iLow2 + 1
>> Wend
>>
>> 'Find the last item that is less than the mid-point item
>> While avArray(iHigh2, iKey) > vItem1 And iHigh2 > iLow1
>> iHigh2 = iHigh2 - 1
>> Wend
>> Else
>> 'Find the first item that is less than the mid-point item
>> While avArray(iLow2, iKey) > vItem1 And iLow2 < iHigh1
>> iLow2 = iLow2 + 1
>> Wend
>>
>> 'Find the last item that is greater than the mid-point item
>> While avArray(iHigh2, iKey) < vItem1 And iHigh2 > iLow1
>> iHigh2 = iHigh2 - 1
>> Wend
>> End If
>>
>> 'If the two items are in the wrong order, swap the rows
>> If iLow2 < iHigh2 Then
>> For i = LBound(avArray) To UBound(avArray, 2)
>> vItem2 = avArray(iLow2, i)
>> avArray(iLow2, i) = avArray(iHigh2, i)
>> avArray(iHigh2, i) = vItem2
>> Next
>> End If
>>
>> 'If the pointers are not together, advance to the next item
>> If iLow2 <= iHigh2 Then
>> iLow2 = iLow2 + 1
>> iHigh2 = iHigh2 - 1
>> End If
>> Wend
>>
>> 'Recurse to sort the lower half of the extremes
>> If iHigh2 > iLow1 Then procSort2D avArray, sOrder, iKey, iLow1,
>> iHigh2
>>
>> 'Recurse to sort the upper half of the extremes
>> If iLow2 < iHigh1 Then procSort2D avArray, sOrder, iKey, iLow2,
>> iHigh1
>>
>> Exit Sub
>> ERROROUT:
>>
>> MsgBox "There was an error while sorting a 2-D array" & _
>> vbCrLf & _
>> "___________________________________" & _
>> vbCrLf & vbCrLf & _
>> "most likely there wasn't enough memory" & _
>> vbCrLf & _
>> "the size of this array was" & _
>> vbCrLf & _
>> "rows: " & vbTab & UBound(avArray) & _
>> vbCrLf & _
>> "columns: " & vbTab & UBound(avArray, 2) & _
>> vbCrLf & vbCrLf & _
>> "VBA error" & _
>> vbCrLf & _
>> "source: " & vbTab & Err.Source & _
>> vbCrLf & _
>> "number: " & vbTab & Err.Number & _
>> vbCrLf & _
>> "description:" & vbTab & Err.Description, , ""
>>
>> End Sub
>>
>>
>> Thanks for any advice.
>>
>>
>> RBS
>>
>
>

[RB Smissaert]

Thanks, but I have tried that already and it turned out to be about twice as
slow.
I use it though, because you can sort on more than one field.
Below the code for this:

Sub SQLArraySort(ByRef arrData As Variant, _
ByVal lSortField1 As Long, _
ByVal strSortType1 As String, _
ByVal bHasFields As Boolean, _
ByVal bArrayInput As Boolean, _
ByVal bArrayOutput As Boolean, _
Optional ByVal lCols As Long = 0, _
Optional ByVal strInputFile As String = "", _
Optional ByVal strOutputFile As String = "", _
Optional ByVal lSortField2 As Long = 0, _
Optional ByVal strSortType2 As String = "")

Dim LB1 As Long
Dim UB1 As Long
Dim LB2 As Long
Dim UB2 As Long
Dim c As Long
Dim strFields As String
Dim arrFields
Dim strQuery As String
Dim strOrderString As String
Dim rs As ADODB.Recordset
Dim strTempFile As String
Dim strSortedFile As String
Dim strSchemaFile As String

On Error GoTo ERROROUT

If strInputFile = "" Then
strTempFile = TempTablesFolder & "tmpFile.txt"
strInputFile = "tmpFile.txt"
Else
strTempFile = TempTablesFolder & strInputFile
End If

If strOutputFile = "" Then
strSortedFile = TempTablesFolder & "SortedFile.txt"
strOutputFile = "SortedFile.txt"
Else
strSortedFile = TempTablesFolder & strOutputFile
End If

strSchemaFile = TempTablesFolder & "Schema.ini"

If bArrayInput = True Then
If bFileExists(strTempFile) Then
Kill strTempFile
End If
End If

If bFileExists(strSortedFile) Then
Kill strSortedFile
End If

If bFileExists(strSchemaFile) Then
Kill strSchemaFile
End If

If bArrayInput = False Then
If bHasFields = False Then
'working directly with a text file that has no fields yet
'--------------------------------------------------------
strFields = "Field" & c
If lCols > 1 Then
For c = 2 To lCols
strFields = strFields & ", Field" & c
Next
End If
InsertLineAtBeginningTexFile strTempFile, strFields
Else
'working directly with a text file that has fields already
'---------------------------------------------------------
strFields = GetFieldsFromText(strTempFile, lCols)
End If
End If 'If bArrayInput = False

If bArrayInput = True Then

LB1 = LBound(arrData)
UB1 = UBound(arrData)
LB2 = LBound(arrData, 2)
UB2 = UBound(arrData, 2)

ReDim arrFields(LB2 To UB2) As String

'make the fields string and fields array
'---------------------------------------
If bHasFields = False Then
strFields = "Field" & 1 - LB2
arrFields(LB2) = "Field" & 1 - LB2
If UB1 > LB1 Then
For c = LB2 + 1 To UB2
strFields = strFields & ", " & "Field" & c + (1 - LB2)
arrFields(c) = "Field" & c + (1 - LB2)
Next
End If
Else
strFields = arrData(LB1, LB2)
arrFields(LB2) = arrData(LB1, LB2)
If UB1 > LB1 Then
For c = LB2 + 1 To UB2
strFields = strFields & ", " & arrData(LB1, LB2 + c)
arrFields(c) = arrData(LB1, LB2 + c)
Next
End If
End If 'If bHasFields = False

'write the array to text
'-----------------------
If bHasFields = False Then
SaveArrayToText2 strTempFile, _
arrData, _
LB1, _
UB1, _
LB2, _
UB2, _
arrFields
Else
SaveArrayToText2 strTempFile, _
arrData, _
LB1, _
UB1, _
LB2, _
UB2
End If
End If 'If bArrayInput = True

'make the SQL ORDER clause
'-------------------------
If lSortField2 = 0 Then
If strSortType1 = "A" Then
strOrderString = "ORDER BY " & _
lSortField1 & " ASC"
Else
strOrderString = "ORDER BY " & _
lSortField1 & " DESC"
End If
Else
If strSortType1 = "A" Then
If strSortType2 = "A" Then
strOrderString = "ORDER BY " & _
lSortField1 & " ASC, " & _
lSortField2 & " ASC"
Else
strOrderString = "ORDER BY " & _
lSortField1 & " ASC, " & _
lSortField2 & " DESC"
End If
Else
If strSortType2 = "A" Then
strOrderString = "ORDER BY " & _
lSortField1 & " DESC, " & _
lSortField2 & " ASC"
Else
strOrderString = "ORDER BY " & _
lSortField1 & " DESC, " & _
lSortField2 & " DESC"
End If
End If
End If 'If lSortField2 = 0

'run the SQL to sort the text file
'---------------------------------
strQuery = "SELECT " & _
strFields & _
" INTO " & strOutputFile & _
" IN '" & TempTablesFolder & "' " & _
"'Text;FMT=Delimited' " & _
"FROM " & _
strInputFile & " " & _
strOrderString

ShowStatement strQuery

Set rs = New ADODB.Recordset

rs.Open Source:=strQuery, _
ActiveConnection:=TempTextConn, _
CursorType:=adOpenForwardOnly, _
LockType:=adLockReadOnly, _
Options:=adCmdText

Set rs = Nothing

If bArrayOutput = True Then
'write the textfile back to the array
'------------------------------------
If bHasFields = True Then
OpenTextFileToArray strSortedFile, _
arrData, _
LB1, _
UB1, _
LB2, _
UB2
Else
OpenTextFileToArray strSortedFile, _
arrData, _
LB1, _
UB1, _
LB2, _
UB2, _
True
End If
End If 'If bArrayOutput = Tru

Exit Sub
ERROROUT:

MsgBox "THE SUB SQLSortArray COULDN'T COMPLETE" & _
vbCrLf & _
"DUE TO AN ERROR" & _
vbCrLf & vbCrLf & _
"ERROR NUMBER: " & Err.Number & _
vbCrLf & vbCrLf & _
Err.Description, , "SQLSortArray"

Err.Clear

End Sub


RBS

"Tim Williams" <saxifrax@pacbell*dot*net> wrote in message
news:[email protected]...
> You could try loading your data into an ADO recordset and sorting it
> there.
> Google for "disconnected recordset" and ADO
>
> Tim
>
>
>
> "RB Smissaert" <[email protected]> wrote in message
> news:[email protected]...
>> In my application I often have to sort large 2-D arrays.
>> I have found a routine for this that works quite fast, but thought
>> maybe it could be made faster by making a dll via a COM add-in
>> compiled in Office Developer. This was quite easy to do with the
>> example on Chip Pearson's website.
>> Unfortunately it turns out that sorting the array with this dll is about
>> 8 to 9 times slower.
>> Would there be any way to do this faster? The arrays are often too big
>> for the worksheet, so sorting in the sheet won't work.
>>
>> Below the routine I downloaded. Not sure who wrote it:
>>
>> Sub procSort2D(ByRef avArray, _
>> ByVal sOrder As String, _
>> ByVal iKey As Long, _
>> Optional ByVal iLow1 As Long = -1, _
>> Optional ByVal iHigh1 As Long = -1)
>>
>> On Error GoTo ERROROUT
>>
>> Dim iLow2 As Long
>> Dim iHigh2 As Long
>> Dim i As Long
>> Dim vItem1 As Variant
>> Dim vItem2 As Variant
>>
>> If iLow1 = -1 Then
>> iLow1 = LBound(avArray, 1)
>> End If
>>
>> If iHigh1 = -1 Then
>> iHigh1 = UBound(avArray, 1)
>> End If
>>
>> 'Set new extremes to old extremes
>> iLow2 = iLow1
>> iHigh2 = iHigh1
>>
>> 'Get value of array item in middle of new extremes
>> vItem1 = avArray((iLow1 + iHigh1) \ 2, iKey)
>>
>> 'Loop for all the items in the array between the extremes
>> While iLow2 < iHigh2
>>
>> If sOrder = "A" Then
>> 'Find the first item that is greater than the mid-point item
>> While avArray(iLow2, iKey) < vItem1 And iLow2 < iHigh1
>> iLow2 = iLow2 + 1
>> Wend
>>
>> 'Find the last item that is less than the mid-point item
>> While avArray(iHigh2, iKey) > vItem1 And iHigh2 > iLow1
>> iHigh2 = iHigh2 - 1
>> Wend
>> Else
>> 'Find the first item that is less than the mid-point item
>> While avArray(iLow2, iKey) > vItem1 And iLow2 < iHigh1
>> iLow2 = iLow2 + 1
>> Wend
>>
>> 'Find the last item that is greater than the mid-point item
>> While avArray(iHigh2, iKey) < vItem1 And iHigh2 > iLow1
>> iHigh2 = iHigh2 - 1
>> Wend
>> End If
>>
>> 'If the two items are in the wrong order, swap the rows
>> If iLow2 < iHigh2 Then
>> For i = LBound(avArray) To UBound(avArray, 2)
>> vItem2 = avArray(iLow2, i)
>> avArray(iLow2, i) = avArray(iHigh2, i)
>> avArray(iHigh2, i) = vItem2
>> Next
>> End If
>>
>> 'If the pointers are not together, advance to the next item
>> If iLow2 <= iHigh2 Then
>> iLow2 = iLow2 + 1
>> iHigh2 = iHigh2 - 1
>> End If
>> Wend
>> 'Recurse to sort the lower half of the extremes
>> If iHigh2 > iLow1 Then procSort2D avArray, sOrder, iKey, iLow1, iHigh2
>>
>> 'Recurse to sort the upper half of the extremes
>> If iLow2 < iHigh1 Then procSort2D avArray, sOrder, iKey, iLow2, iHigh1
>>
>> Exit Sub
>> ERROROUT:
>>
>> MsgBox "There was an error while sorting a 2-D array" & _
>> vbCrLf & _
>> "___________________________________" & _
>> vbCrLf & vbCrLf & _
>> "most likely there wasn't enough memory" & _
>> vbCrLf & _
>> "the size of this array was" & _
>> vbCrLf & _
>> "rows: " & vbTab & UBound(avArray) & _
>> vbCrLf & _
>> "columns: " & vbTab & UBound(avArray, 2) & _
>> vbCrLf & vbCrLf & _
>> "VBA error" & _
>> vbCrLf & _
>> "source: " & vbTab & Err.Source & _
>> vbCrLf & _
>> "number: " & vbTab & Err.Number & _
>> vbCrLf & _
>> "description:" & vbTab & Err.Description, , ""
>>
>> End Sub
>>
>>
>> Thanks for any advice.
>>
>>
>> RBS
>>
>
>

[RB Smissaert]

OK, if Stephen Bullen wrote it I will make a mention of that in my code.

RBS


"Norman Jones" <[email protected]> wrote in message
news:[email protected]...
> Hi RB,
>
>> Below the routine I downloaded. Not sure who wrote it:
>
> I believe that the Sub procSort2D routine would have been downloaded as
> part of Stephen Bullen's QuickSort demo.
>
>
> You have reponses to the substantive question, but I shall watch the
> thread with interest.
>
>
> ---
> Regards,
> Norman
>
>
>
> "RB Smissaert" <[email protected]> wrote in message
> news:[email protected]...
>> In my application I often have to sort large 2-D arrays.
>> I have found a routine for this that works quite fast, but thought
>> maybe it could be made faster by making a dll via a COM add-in
>> compiled in Office Developer. This was quite easy to do with the
>> example on Chip Pearson's website.
>> Unfortunately it turns out that sorting the array with this dll is about
>> 8 to 9 times slower.
>> Would there be any way to do this faster? The arrays are often too big
>> for the worksheet, so sorting in the sheet won't work.
>>
>> Below the routine I downloaded. Not sure who wrote it:
>>
>> Sub procSort2D(ByRef avArray, _
>> ByVal sOrder As String, _
>> ByVal iKey As Long, _
>> Optional ByVal iLow1 As Long = -1, _
>> Optional ByVal iHigh1 As Long = -1)
>>
>> On Error GoTo ERROROUT
>>
>> Dim iLow2 As Long
>> Dim iHigh2 As Long
>> Dim i As Long
>> Dim vItem1 As Variant
>> Dim vItem2 As Variant
>>
>> If iLow1 = -1 Then
>> iLow1 = LBound(avArray, 1)
>> End If
>>
>> If iHigh1 = -1 Then
>> iHigh1 = UBound(avArray, 1)
>> End If
>>
>> 'Set new extremes to old extremes
>> iLow2 = iLow1
>> iHigh2 = iHigh1
>>
>> 'Get value of array item in middle of new extremes
>> vItem1 = avArray((iLow1 + iHigh1) \ 2, iKey)
>>
>> 'Loop for all the items in the array between the extremes
>> While iLow2 < iHigh2
>>
>> If sOrder = "A" Then
>> 'Find the first item that is greater than the mid-point item
>> While avArray(iLow2, iKey) < vItem1 And iLow2 < iHigh1
>> iLow2 = iLow2 + 1
>> Wend
>>
>> 'Find the last item that is less than the mid-point item
>> While avArray(iHigh2, iKey) > vItem1 And iHigh2 > iLow1
>> iHigh2 = iHigh2 - 1
>> Wend
>> Else
>> 'Find the first item that is less than the mid-point item
>> While avArray(iLow2, iKey) > vItem1 And iLow2 < iHigh1
>> iLow2 = iLow2 + 1
>> Wend
>>
>> 'Find the last item that is greater than the mid-point item
>> While avArray(iHigh2, iKey) < vItem1 And iHigh2 > iLow1
>> iHigh2 = iHigh2 - 1
>> Wend
>> End If
>>
>> 'If the two items are in the wrong order, swap the rows
>> If iLow2 < iHigh2 Then
>> For i = LBound(avArray) To UBound(avArray, 2)
>> vItem2 = avArray(iLow2, i)
>> avArray(iLow2, i) = avArray(iHigh2, i)
>> avArray(iHigh2, i) = vItem2
>> Next
>> End If
>>
>> 'If the pointers are not together, advance to the next item
>> If iLow2 <= iHigh2 Then
>> iLow2 = iLow2 + 1
>> iHigh2 = iHigh2 - 1
>> End If
>> Wend
>> 'Recurse to sort the lower half of the extremes
>> If iHigh2 > iLow1 Then procSort2D avArray, sOrder, iKey, iLow1, iHigh2
>>
>> 'Recurse to sort the upper half of the extremes
>> If iLow2 < iHigh1 Then procSort2D avArray, sOrder, iKey, iLow2, iHigh1
>>
>> Exit Sub
>> ERROROUT:
>>
>> MsgBox "There was an error while sorting a 2-D array" & _
>> vbCrLf & _
>> "___________________________________" & _
>> vbCrLf & vbCrLf & _
>> "most likely there wasn't enough memory" & _
>> vbCrLf & _
>> "the size of this array was" & _
>> vbCrLf & _
>> "rows: " & vbTab & UBound(avArray) & _
>> vbCrLf & _
>> "columns: " & vbTab & UBound(avArray, 2) & _
>> vbCrLf & vbCrLf & _
>> "VBA error" & _
>> vbCrLf & _
>> "source: " & vbTab & Err.Source & _
>> vbCrLf & _
>> "number: " & vbTab & Err.Number & _
>> vbCrLf & _
>> "description:" & vbTab & Err.Description, , ""
>>
>> End Sub
>>
>>
>> Thanks for any advice.
>>
>>
>> RBS
>>
>
>

[RB Smissaert]

Daniel,

Tried it with VSort of MoreFunc and it is faster indeed!
A simple test shows me it is about 4 to 5 times faster than the Sub
procSort2D.
So thanks for the tip. I will now have to check if the array gets sorted OK,
but I
imagine that this will be fine. Another bonus of VSort is that you can sort
on multiple
columns, so altogether it seems that this is the best solution for sorting
2-D arrays.
Below my testing code:

Option Explicit
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private lStartTime As Long
Private lEndTime As Long

Sub test()

Dim arr(1 To 10000, 1 To 5) As Long
Dim arr2
Dim i As Long
Dim c As Long
Dim bDoMoreFunc As Boolean
Dim strMsg As String

If MsgBox("Use MoreFunc?", _
vbYesNo + vbDefaultButton1, _
"sort 2-D array") = vbYes Then
bDoMoreFunc = True
End If

For i = 1 To 10000
arr(i, 1) = Int((i * Rnd) + 1)
For c = 2 To 5
arr(i, c) = i
Next
Next

lStartTime = timeGetTime()

If bDoMoreFunc = True Then
arr2 = Application.Run([VSORT], arr, arr, 0)
strMsg = "with MoreFunc"
Else
sort2DArray arr, "D", 1
strMsg = "sort2DArray"
End If

lEndTime = timeGetTime()

If bDoMoreFunc = True Then
MsgBox "Descending sort done in " & lEndTime - lStartTime & "
msecs", , _
strMsg & ", arr2(1, 1) now " & arr2(1, 1)
Else
MsgBox "Descending sort done in " & lEndTime - lStartTime & "
msecs", , _
strMsg & ", arr(1, 1) now " & arr(1, 1)
End If

End Sub

Sub procSort2D(ByRef avArray, _
ByVal sOrder As String, _
ByVal iKey As Long, _
Optional ByVal iLow1 As Long = -1, _
Optional ByVal iHigh1 As Long = -1)

On Error GoTo ERROROUT

Dim iLow2 As Long
Dim iHigh2 As Long
Dim i As Long
Dim vItem1 As Variant
Dim vItem2 As Variant

If iLow1 = -1 Then
iLow1 = LBound(avArray, 1)
End If

If iHigh1 = -1 Then
iHigh1 = UBound(avArray, 1)
End If

'Set new extremes to old extremes
iLow2 = iLow1
iHigh2 = iHigh1

'Get value of array item in middle of new extremes
vItem1 = avArray((iLow1 + iHigh1) \ 2, iKey)

'Loop for all the items in the array between the extremes
While iLow2 < iHigh2

If sOrder = "A" Then
'Find the first item that is greater than the mid-point item
While avArray(iLow2, iKey) < vItem1 And iLow2 < iHigh1
iLow2 = iLow2 + 1
Wend

'Find the last item that is less than the mid-point item
While avArray(iHigh2, iKey) > vItem1 And iHigh2 > iLow1
iHigh2 = iHigh2 - 1
Wend
Else
'Find the first item that is less than the mid-point item
While avArray(iLow2, iKey) > vItem1 And iLow2 < iHigh1
iLow2 = iLow2 + 1
Wend

'Find the last item that is greater than the mid-point item
While avArray(iHigh2, iKey) < vItem1 And iHigh2 > iLow1
iHigh2 = iHigh2 - 1
Wend
End If

'If the two items are in the wrong order, swap the rows
If iLow2 < iHigh2 Then
For i = LBound(avArray) To UBound(avArray, 2)
vItem2 = avArray(iLow2, i)
avArray(iLow2, i) = avArray(iHigh2, i)
avArray(iHigh2, i) = vItem2
Next
End If

'If the pointers are not together, advance to the next item
If iLow2 <= iHigh2 Then
iLow2 = iLow2 + 1
iHigh2 = iHigh2 - 1
End If
Wend

'Recurse to sort the lower half of the extremes
If iHigh2 > iLow1 Then procSort2D avArray, sOrder, iKey, iLow1, iHigh2

'Recurse to sort the upper half of the extremes
If iLow2 < iHigh1 Then procSort2D avArray, sOrder, iKey, iLow2, iHigh1

Exit Sub
ERROROUT:

End Sub



RBS



"Daniel.M" <[email protected]> wrote in message
news:%[email protected]...
> Hi,
>
> Use Laurent Longre's VSORT (or VSORT.IDX) function available in his
> MOREFUNC.XLL
> It's built in 'C' (using pointers for swapping elements) so it's quite
> fast.
>
> Once installed, it can be invoked in VBA as in:
> Dim V As Variant
> V = Application.Run([VSORT], Range("A1:B20"), 1)
>
> Regards,
>
> Daniel M.
>
> "RB Smissaert" <[email protected]> wrote in message
> news:[email protected]...
>> In my application I often have to sort large 2-D arrays.
>> I have found a routine for this that works quite fast, but thought
>> maybe it could be made faster by making a dll via a COM add-in
>> compiled in Office Developer. This was quite easy to do with the
>> example on Chip Pearson's website.
>> Unfortunately it turns out that sorting the array with this dll is about
>> 8 to 9 times slower.
>> Would there be any way to do this faster? The arrays are often too big
>> for the worksheet, so sorting in the sheet won't work.
>>
>> Below the routine I downloaded. Not sure who wrote it:
>>
>> Sub procSort2D(ByRef avArray, _
>> ByVal sOrder As String, _
>> ByVal iKey As Long, _
>> Optional ByVal iLow1 As Long = -1, _
>> Optional ByVal iHigh1 As Long = -1)
>>
>> On Error GoTo ERROROUT
>>
>> Dim iLow2 As Long
>> Dim iHigh2 As Long
>> Dim i As Long
>> Dim vItem1 As Variant
>> Dim vItem2 As Variant
>>
>> If iLow1 = -1 Then
>> iLow1 = LBound(avArray, 1)
>> End If
>>
>> If iHigh1 = -1 Then
>> iHigh1 = UBound(avArray, 1)
>> End If
>>
>> 'Set new extremes to old extremes
>> iLow2 = iLow1
>> iHigh2 = iHigh1
>>
>> 'Get value of array item in middle of new extremes
>> vItem1 = avArray((iLow1 + iHigh1) \ 2, iKey)
>>
>> 'Loop for all the items in the array between the extremes
>> While iLow2 < iHigh2
>>
>> If sOrder = "A" Then
>> 'Find the first item that is greater than the mid-point item
>> While avArray(iLow2, iKey) < vItem1 And iLow2 < iHigh1
>> iLow2 = iLow2 + 1
>> Wend
>>
>> 'Find the last item that is less than the mid-point item
>> While avArray(iHigh2, iKey) > vItem1 And iHigh2 > iLow1
>> iHigh2 = iHigh2 - 1
>> Wend
>> Else
>> 'Find the first item that is less than the mid-point item
>> While avArray(iLow2, iKey) > vItem1 And iLow2 < iHigh1
>> iLow2 = iLow2 + 1
>> Wend
>>
>> 'Find the last item that is greater than the mid-point item
>> While avArray(iHigh2, iKey) < vItem1 And iHigh2 > iLow1
>> iHigh2 = iHigh2 - 1
>> Wend
>> End If
>>
>> 'If the two items are in the wrong order, swap the rows
>> If iLow2 < iHigh2 Then
>> For i = LBound(avArray) To UBound(avArray, 2)
>> vItem2 = avArray(iLow2, i)
>> avArray(iLow2, i) = avArray(iHigh2, i)
>> avArray(iHigh2, i) = vItem2
>> Next
>> End If
>>
>> 'If the pointers are not together, advance to the next item
>> If iLow2 <= iHigh2 Then
>> iLow2 = iLow2 + 1
>> iHigh2 = iHigh2 - 1
>> End If
>> Wend
>>
>> 'Recurse to sort the lower half of the extremes
>> If iHigh2 > iLow1 Then procSort2D avArray, sOrder, iKey, iLow1,
>> iHigh2
>>
>> 'Recurse to sort the upper half of the extremes
>> If iLow2 < iHigh1 Then procSort2D avArray, sOrder, iKey, iLow2,
>> iHigh1
>>
>> Exit Sub
>> ERROROUT:
>>
>> MsgBox "There was an error while sorting a 2-D array" & _
>> vbCrLf & _
>> "___________________________________" & _
>> vbCrLf & vbCrLf & _
>> "most likely there wasn't enough memory" & _
>> vbCrLf & _
>> "the size of this array was" & _
>> vbCrLf & _
>> "rows: " & vbTab & UBound(avArray) & _
>> vbCrLf & _
>> "columns: " & vbTab & UBound(avArray, 2) & _
>> vbCrLf & vbCrLf & _
>> "VBA error" & _
>> vbCrLf & _
>> "source: " & vbTab & Err.Source & _
>> vbCrLf & _
>> "number: " & vbTab & Err.Number & _
>> vbCrLf & _
>> "description:" & vbTab & Err.Description, , ""
>>
>> End Sub
>>
>>
>> Thanks for any advice.
>>
>>
>> RBS
>>
>
>

[RB Smissaert]

There is just one thing that is not clear to me.
The help file mainly talks about sorting ranges and it makes it clear how
to choose the sort column, but how does this work with arrays?
Say I have a 10 column array and want to sort ascending on column 2
and descending on column 5, how would that work?

RBS


"Daniel.M" <[email protected]> wrote in message
news:%[email protected]...
> Hi,
>
> Use Laurent Longre's VSORT (or VSORT.IDX) function available in his
> MOREFUNC.XLL
> It's built in 'C' (using pointers for swapping elements) so it's quite
> fast.
>
> Once installed, it can be invoked in VBA as in:
> Dim V As Variant
> V = Application.Run([VSORT], Range("A1:B20"), 1)
>
> Regards,
>
> Daniel M.
>
> "RB Smissaert" <[email protected]> wrote in message
> news:[email protected]...
>> In my application I often have to sort large 2-D arrays.
>> I have found a routine for this that works quite fast, but thought
>> maybe it could be made faster by making a dll via a COM add-in
>> compiled in Office Developer. This was quite easy to do with the
>> example on Chip Pearson's website.
>> Unfortunately it turns out that sorting the array with this dll is about
>> 8 to 9 times slower.
>> Would there be any way to do this faster? The arrays are often too big
>> for the worksheet, so sorting in the sheet won't work.
>>
>> Below the routine I downloaded. Not sure who wrote it:
>>
>> Sub procSort2D(ByRef avArray, _
>> ByVal sOrder As String, _
>> ByVal iKey As Long, _
>> Optional ByVal iLow1 As Long = -1, _
>> Optional ByVal iHigh1 As Long = -1)
>>
>> On Error GoTo ERROROUT
>>
>> Dim iLow2 As Long
>> Dim iHigh2 As Long
>> Dim i As Long
>> Dim vItem1 As Variant
>> Dim vItem2 As Variant
>>
>> If iLow1 = -1 Then
>> iLow1 = LBound(avArray, 1)
>> End If
>>
>> If iHigh1 = -1 Then
>> iHigh1 = UBound(avArray, 1)
>> End If
>>
>> 'Set new extremes to old extremes
>> iLow2 = iLow1
>> iHigh2 = iHigh1
>>
>> 'Get value of array item in middle of new extremes
>> vItem1 = avArray((iLow1 + iHigh1) \ 2, iKey)
>>
>> 'Loop for all the items in the array between the extremes
>> While iLow2 < iHigh2
>>
>> If sOrder = "A" Then
>> 'Find the first item that is greater than the mid-point item
>> While avArray(iLow2, iKey) < vItem1 And iLow2 < iHigh1
>> iLow2 = iLow2 + 1
>> Wend
>>
>> 'Find the last item that is less than the mid-point item
>> While avArray(iHigh2, iKey) > vItem1 And iHigh2 > iLow1
>> iHigh2 = iHigh2 - 1
>> Wend
>> Else
>> 'Find the first item that is less than the mid-point item
>> While avArray(iLow2, iKey) > vItem1 And iLow2 < iHigh1
>> iLow2 = iLow2 + 1
>> Wend
>>
>> 'Find the last item that is greater than the mid-point item
>> While avArray(iHigh2, iKey) < vItem1 And iHigh2 > iLow1
>> iHigh2 = iHigh2 - 1
>> Wend
>> End If
>>
>> 'If the two items are in the wrong order, swap the rows
>> If iLow2 < iHigh2 Then
>> For i = LBound(avArray) To UBound(avArray, 2)
>> vItem2 = avArray(iLow2, i)
>> avArray(iLow2, i) = avArray(iHigh2, i)
>> avArray(iHigh2, i) = vItem2
>> Next
>> End If
>>
>> 'If the pointers are not together, advance to the next item
>> If iLow2 <= iHigh2 Then
>> iLow2 = iLow2 + 1
>> iHigh2 = iHigh2 - 1
>> End If
>> Wend
>>
>> 'Recurse to sort the lower half of the extremes
>> If iHigh2 > iLow1 Then procSort2D avArray, sOrder, iKey, iLow1,
>> iHigh2
>>
>> 'Recurse to sort the upper half of the extremes
>> If iLow2 < iHigh1 Then procSort2D avArray, sOrder, iKey, iLow2,
>> iHigh1
>>
>> Exit Sub
>> ERROROUT:
>>
>> MsgBox "There was an error while sorting a 2-D array" & _
>> vbCrLf & _
>> "___________________________________" & _
>> vbCrLf & vbCrLf & _
>> "most likely there wasn't enough memory" & _
>> vbCrLf & _
>> "the size of this array was" & _
>> vbCrLf & _
>> "rows: " & vbTab & UBound(avArray) & _
>> vbCrLf & _
>> "columns: " & vbTab & UBound(avArray, 2) & _
>> vbCrLf & vbCrLf & _
>> "VBA error" & _
>> vbCrLf & _
>> "source: " & vbTab & Err.Source & _
>> vbCrLf & _
>> "number: " & vbTab & Err.Number & _
>> vbCrLf & _
>> "description:" & vbTab & Err.Description, , ""
>>
>> End Sub
>>
>>
>> Thanks for any advice.
>>
>>
>> RBS
>>
>
>

[RB Smissaert]

I think I worked this all out now.
Although it will need making an extra (the array holding the values to sort
on)
it is still 4 to 5 times faster than a QuickSort.
I have made a simple wrapper function that makes sorting arrays with this a
bit easier.
I only needed it to sort up to 3 fields, but you could alter it to go up to
14 fields.


Function VSORTArray(ByRef arr As Variant, _
ByVal btCol1 As Byte, _
ByVal strSortType1 As String, _
Optional ByVal btCol2 As Byte = 0, _
Optional ByVal strSortType2 As String = "", _
Optional ByVal btCol3 As Byte = 0, _
Optional ByVal strSortType3 As String = "") As Variant

'------------------------------------------------------------------
'http://longre.free.fr/english/
'Uses Laurent Longre's VSort function in the .xll add-in MoreFunc
'Will be about 4 to 5 times faster than a quicksort and can sort
'on multiple columns.
'Done up to 3 columns here, but can be done up to 14 columns
'------------------------------------------------------------------
'will sort an 0-based or 1-based 2-D array with up to 3 sort keys
'the field key has to be supplied as a byte, where the first column
'of the array is 1, even if it is an 0-based array
'the sort type has to be given as "a", "A" , "b" or "B"
'examples:
'sorting on 1 field: arr2 = VSORTArray(arr, 1, "A")
'sorting on 2 fields: arr2 = VSORTArray(arr, 2, "D", 5, "A")
'------------------------------------------------------------------

Dim i As Long
Dim LB1 As Long
Dim UB1 As Long
Dim arrKey1
Dim arrKey2
Dim arrKey3
Dim btSortType1 As Byte
Dim btSortType2 As Byte
Dim btSortType3 As Byte
Dim arrFinal

LB1 = LBound(arr)
UB1 = UBound(arr)

'make the array for key 1
'------------------------
ReDim arrKey1(LB1 To UB1, LB1 To LB1)
For i = LB1 To UB1
arrKey1(i, LB1) = arr(i, btCol1 - (1 - LB1))
Next

'set the sort type for key 1
'---------------------------
If UCase(strSortType1) = "A" Then
btSortType1 = 1
Else
btSortType1 = 0
End If

If Not btCol2 = 0 Then
'make the array for key 2
'------------------------
ReDim arrKey2(LB1 To UB1, LB1 To LB1)

For i = LB1 To UB1
arrKey2(i, LB1) = arr(i, btCol2 - (1 - LB1))
Next

'set the sort type for key 2
'---------------------------
If UCase(strSortType2) = "A" Then
btSortType2 = 1
Else
btSortType2 = 0
End If
End If

If Not btCol3 = 0 Then
'make the array for key 3
'------------------------
ReDim arrKey3(LB1 To UB1, LB1 To LB1)
For i = LB1 To UB1
arrKey3(i, LB1) = arr(i, btCol3 - (1 - LB1))
Next

'set the sort type for key 3
'---------------------------
If UCase(strSortType3) = "A" Then
btSortType3 = 1
Else
btSortType3 = 0
End If
End If

If Not strSortType3 = "" Then
'3 fields to sort on
'-------------------
arrFinal = Application.Run([VSORT], arr, _
arrKey1, btSortType1, _
arrKey2, btSortType2, _
arrKey3, btSortType3)
Else
'2 fields to sort on
'-------------------
If Not strSortType2 = "" Then
arrFinal = Application.Run([VSORT], arr, _
arrKey1, btSortType1, _
arrKey2, btSortType2)
Else
'1 field to sort on
'------------------
arrFinal = Application.Run([VSORT], _
arr, arrKey1, btSortType1)
End If
End If

VSORTArray = arrFinal

End Function


RBS


"Daniel.M" <[email protected]> wrote in message
news:%[email protected]...
> Hi,
>
> Use Laurent Longre's VSORT (or VSORT.IDX) function available in his
> MOREFUNC.XLL
> It's built in 'C' (using pointers for swapping elements) so it's quite
> fast.
>
> Once installed, it can be invoked in VBA as in:
> Dim V As Variant
> V = Application.Run([VSORT], Range("A1:B20"), 1)
>
> Regards,
>
> Daniel M.
>
> "RB Smissaert" <[email protected]> wrote in message
> news:[email protected]...
>> In my application I often have to sort large 2-D arrays.
>> I have found a routine for this that works quite fast, but thought
>> maybe it could be made faster by making a dll via a COM add-in
>> compiled in Office Developer. This was quite easy to do with the
>> example on Chip Pearson's website.
>> Unfortunately it turns out that sorting the array with this dll is about
>> 8 to 9 times slower.
>> Would there be any way to do this faster? The arrays are often too big
>> for the worksheet, so sorting in the sheet won't work.
>>
>> Below the routine I downloaded. Not sure who wrote it:
>>
>> Sub procSort2D(ByRef avArray, _
>> ByVal sOrder As String, _
>> ByVal iKey As Long, _
>> Optional ByVal iLow1 As Long = -1, _
>> Optional ByVal iHigh1 As Long = -1)
>>
>> On Error GoTo ERROROUT
>>
>> Dim iLow2 As Long
>> Dim iHigh2 As Long
>> Dim i As Long
>> Dim vItem1 As Variant
>> Dim vItem2 As Variant
>>
>> If iLow1 = -1 Then
>> iLow1 = LBound(avArray, 1)
>> End If
>>
>> If iHigh1 = -1 Then
>> iHigh1 = UBound(avArray, 1)
>> End If
>>
>> 'Set new extremes to old extremes
>> iLow2 = iLow1
>> iHigh2 = iHigh1
>>
>> 'Get value of array item in middle of new extremes
>> vItem1 = avArray((iLow1 + iHigh1) \ 2, iKey)
>>
>> 'Loop for all the items in the array between the extremes
>> While iLow2 < iHigh2
>>
>> If sOrder = "A" Then
>> 'Find the first item that is greater than the mid-point item
>> While avArray(iLow2, iKey) < vItem1 And iLow2 < iHigh1
>> iLow2 = iLow2 + 1
>> Wend
>>
>> 'Find the last item that is less than the mid-point item
>> While avArray(iHigh2, iKey) > vItem1 And iHigh2 > iLow1
>> iHigh2 = iHigh2 - 1
>> Wend
>> Else
>> 'Find the first item that is less than the mid-point item
>> While avArray(iLow2, iKey) > vItem1 And iLow2 < iHigh1
>> iLow2 = iLow2 + 1
>> Wend
>>
>> 'Find the last item that is greater than the mid-point item
>> While avArray(iHigh2, iKey) < vItem1 And iHigh2 > iLow1
>> iHigh2 = iHigh2 - 1
>> Wend
>> End If
>>
>> 'If the two items are in the wrong order, swap the rows
>> If iLow2 < iHigh2 Then
>> For i = LBound(avArray) To UBound(avArray, 2)
>> vItem2 = avArray(iLow2, i)
>> avArray(iLow2, i) = avArray(iHigh2, i)
>> avArray(iHigh2, i) = vItem2
>> Next
>> End If
>>
>> 'If the pointers are not together, advance to the next item
>> If iLow2 <= iHigh2 Then
>> iLow2 = iLow2 + 1
>> iHigh2 = iHigh2 - 1
>> End If
>> Wend
>>
>> 'Recurse to sort the lower half of the extremes
>> If iHigh2 > iLow1 Then procSort2D avArray, sOrder, iKey, iLow1,
>> iHigh2
>>
>> 'Recurse to sort the upper half of the extremes
>> If iLow2 < iHigh1 Then procSort2D avArray, sOrder, iKey, iLow2,
>> iHigh1
>>
>> Exit Sub
>> ERROROUT:
>>
>> MsgBox "There was an error while sorting a 2-D array" & _
>> vbCrLf & _
>> "___________________________________" & _
>> vbCrLf & vbCrLf & _
>> "most likely there wasn't enough memory" & _
>> vbCrLf & _
>> "the size of this array was" & _
>> vbCrLf & _
>> "rows: " & vbTab & UBound(avArray) & _
>> vbCrLf & _
>> "columns: " & vbTab & UBound(avArray, 2) & _
>> vbCrLf & vbCrLf & _
>> "VBA error" & _
>> vbCrLf & _
>> "source: " & vbTab & Err.Source & _
>> vbCrLf & _
>> "number: " & vbTab & Err.Number & _
>> vbCrLf & _
>> "description:" & vbTab & Err.Description, , ""
>>
>> End Sub
>>
>>
>> Thanks for any advice.
>>
>>
>> RBS
>>
>
>

[onedaywhen]

RB Smissaert wrote:
> > You could try loading your data into an ADO recordset and sorting
it
> > there.
> > Google for "disconnected recordset" and ADO
>
> Thanks, but I have tried that already and it turned out to be about
twice
> as slow.

To be fair, you are not doing as Tim suggested in your code, which has
too many missing dependencies (e.g. sub procedure SaveArrayToText2) to
test <g>.

Rather than fabricating a recordset, your code appears to fabricate a
text file. FWIW I don't think your recordset ever gets opened/populated
because the SELECT..INTO..FROM syntax does not return a rowset.

BTW do you have a business requirement to use text files as databases?
Fabricating an .mdb file would yield better performance but I still
have your PATIENT.txt and ENTRY.txt files from way back when to create
an example JOIN between text files.

Jamie.

--

[RB Smissaert]

OK, I include the missing dependencies, so you can test.
The reason I use text files is that people that use my software sometimes
have no Access. The other thing is that it surprisingly appears just as
fast.
If you can convince me that Access is faster I might have another look
at using that.


Function OpenTextFileToArray(ByVal txtFile As String, _
ByRef arr As Variant, _
ByVal LBRow As Long, _
ByVal UBRow As Long, _
ByVal LBCol As Long, _
ByVal UBCol As Long, _
Optional ByVal bSkipFields As Boolean = False)
As Variant

Dim hFile As Long
Dim r As Long
Dim c As Long
Dim varWaste

hFile = FreeFile

Open txtFile For Input As #hFile

On Error Resume Next

If bSkipFields = False Then
For r = LBRow To UBRow
For c = LBCol To UBCol
Input #hFile, arr(r, c)
Next
Next
Else
For c = LBCol To UBCol
Input #hFile, varWaste
Next
For r = LBRow To UBRow
For c = LBCol To UBCol
Input #hFile, arr(r, c)
Next
Next
End If

Close #hFile

OpenTextFileToArray = arr

End Function


Sub SaveArrayToText2(ByVal txtFile As String, _
ByRef arr As Variant, _
Optional ByVal LBRow As Long = -1, _
Optional ByVal UBRow As Long = -1, _
Optional ByVal LBCol As Long = -1, _
Optional ByVal UBCol As Long = -1, _
Optional ByRef fieldArr As Variant)

'this one organises the text file like
'a table by inserting the right line breaks
'------------------------------------------
Dim r As Long
Dim c As Long
Dim hFile As Long

If LBRow = -1 Then
LBRow = LBound(arr, 1)
End If

If UBRow = -1 Then
UBRow = UBound(arr, 1)
End If

If LBCol = -1 Then
LBCol = LBound(arr, 2)
End If

If UBCol = -1 Then
UBCol = UBound(arr, 2)
End If

hFile = FreeFile

Open txtFile For Output As hFile

If IsMissing(fieldArr) Then
For r = LBRow To UBRow
For c = LBCol To UBCol
If c = UBCol Then
Write #hFile, arr(r, c)
Else
Write #hFile, arr(r, c);
End If
Next
Next
Else
For c = LBCol To UBCol
If c = UBCol Then
Write #hFile, fieldArr(c)
Else
Write #hFile, fieldArr(c);
End If
Next
For r = LBRow To UBRow
For c = LBCol To UBCol
If c = UBCol Then
Write #hFile, arr(r, c)
Else
Write #hFile, arr(r, c);
End If
Next
Next
End If

Close #hFile

End Sub


Sub InsertLineAtBeginningTexFile(ByVal strFile As String, ByVal strLine As
String)

Dim FFile As Integer
Dim FileContents As String
Dim NewString As String

FFile = FreeFile
Open strFile For Binary As #FFile
FileContents = Space(FileLen(strFile))
Get #FFile, , FileContents
Close #FFile

NewString = strLine & vbCrLf
FileContents = NewString & FileContents

Open strFile For Binary As #FFile
Put #FFile, , FileContents
Close #FFile

End Sub


Function GetFieldsFromText(ByVal strFile As String, ByVal lCols As Long) As
String

Dim hFile As Long
Dim strTemp As String
Dim strResult As String
Dim c As Long

hFile = FreeFile

Open strFile For Input As #hFile

On Error Resume Next

For c = 1 To lCols
Input #hFile, strTemp
If c = 1 Then
strResult = strTemp
Else
strResult = strResult & ", " & strTemp
End If
Next

Close #hFile

GetFieldsFromText = strResult

End Function



RBS



"onedaywhen" <[email protected]> wrote in message
news:[email protected]...
>
> RB Smissaert wrote:
>> > You could try loading your data into an ADO recordset and sorting
> it
>> > there.
>> > Google for "disconnected recordset" and ADO
>>
>> Thanks, but I have tried that already and it turned out to be about
> twice
>> as slow.
>
> To be fair, you are not doing as Tim suggested in your code, which has
> too many missing dependencies (e.g. sub procedure SaveArrayToText2) to
> test <g>.
>
> Rather than fabricating a recordset, your code appears to fabricate a
> text file. FWIW I don't think your recordset ever gets opened/populated
> because the SELECT..INTO..FROM syntax does not return a rowset.
>
> BTW do you have a business requirement to use text files as databases?
> Fabricating an .mdb file would yield better performance but I still
> have your PATIENT.txt and ENTRY.txt files from way back when to create
> an example JOIN between text files.
>
> Jamie.
>
> --
>

[Daniel.M]

Hi,

> I think I worked this all out now.
> Although it will need making an extra (the array holding the values to sort
> on)

You could assign to new array sorted to the old one (depending on your needs).
arr = VSORTArray(arr,...)

Note that in cases of big arrays to sort and depending on the problem (you know,
I don't), it might be a good idea to look at VSORT.IDX function which only
returns 1 column wide of INDEXES, that is pointers to the indices of the 'rows'
as if they were sorted. It's a very powerful function.

Regards,

Daniel M.

[onedaywhen]

RB Smissaert wrote:
> OK, I include the missing dependencies, so you can test.

There are still some missing ones which I could figure out i.e.
TempTablesFolder, TempTextConn, ShowStatement and bFileExists. Oh yeah,
then there's the gazillion row array which would prove more difficult
<g>.

What sort of absolute times are involved here? I tested your code on a
10K row 2D array and it completed in under 300 milliseconds so I'll
pass on trying to halve this time.

> The reason I use text files is that people that use my software
sometimes
> have no Access.

If you have ADO you don't need the MS Access app to create, maintain
and use Jet .mdb databases. But that's another story.

> The other thing is that it surprisingly appears just as
> fast.

Agreed.

> If you can convince me that Access is faster I might have another
look
> at using that.

I was BTW'ing generally rather than for this particular issue <g>. I
could probably convince you that a Jet database has better data typing,
data/referential integrity features, SQL syntax support, security, etc
but then you didn't ask for that.

One advantage your text file approach has is the *lack* of data typing
- with a fabricated recordset you'd have to choose a data type to use
for a column which could affect its sort order e.g. numerics sorted as
text.

Jamie.

--

[RB Smissaert]

Yes, sorry, I left a few in there:


The line ShowStatement strQuery can just be deleted.

Then there are a number of Public variables:

strLocalDrive will normally be "C"

TempTextConn = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strLocalDrive &
":\RBSSynergyReporting\TempTables\;" & _
"Extended Properties=Text;"

TempTablesFolder = _
strLocalDrive & ":\RBSSynergyReporting\TempTables\"

And then the simple function:

Function bFileExists(strFile As String) As Boolean
bFileExists = (Len(Dir(strFile)) > 0)
End Function

I think now you could make it work.

I remember you telling me about running a .mdb file without Access. Must
have look at that
one day. For now I am quite happy with the text files. I agree the sorting
is not slow as it is.


RBS


"onedaywhen" <[email protected]> wrote in message
news:[email protected]...
> RB Smissaert wrote:
>> OK, I include the missing dependencies, so you can test.
>
> There are still some missing ones which I could figure out i.e.
> TempTablesFolder, TempTextConn, ShowStatement and bFileExists. Oh yeah,
> then there's the gazillion row array which would prove more difficult
> <g>.
>
> What sort of absolute times are involved here? I tested your code on a
> 10K row 2D array and it completed in under 300 milliseconds so I'll
> pass on trying to halve this time.
>
>> The reason I use text files is that people that use my software
> sometimes
>> have no Access.
>
> If you have ADO you don't need the MS Access app to create, maintain
> and use Jet .mdb databases. But that's another story.
>
>> The other thing is that it surprisingly appears just as
>> fast.
>
> Agreed.
>
>> If you can convince me that Access is faster I might have another
> look
>> at using that.
>
> I was BTW'ing generally rather than for this particular issue <g>. I
> could probably convince you that a Jet database has better data typing,
> data/referential integrity features, SQL syntax support, security, etc
> but then you didn't ask for that.
>
> One advantage your text file approach has is the *lack* of data typing
> - with a fabricated recordset you'd have to choose a data type to use
> for a column which could affect its sort order e.g. numerics sorted as
> text.
>
> Jamie.
>
> --
>

[RB Smissaert]

I have come across one major problem and that is that the VSORT routine
will change 0-based arrays to 1-based arrays. I have searched everywhere
about this, but couldn't find anything about it. I have e-mailed Laurent
Longre
and maybe he can help out.
Had a look at the help about VSORT.IDX, but not sure how it would help me
sorting a 2-D array, particularly an 0-based 2-D array where I want to keep
the
base at 0.

RBS


"Daniel.M" <[email protected]> wrote in message
news:[email protected]...
> Hi,
>
>> I think I worked this all out now.
>> Although it will need making an extra (the array holding the values to
>> sort
>> on)
>
> You could assign to new array sorted to the old one (depending on your
> needs).
> arr = VSORTArray(arr,...)
>
> Note that in cases of big arrays to sort and depending on the problem (you
> know,
> I don't), it might be a good idea to look at VSORT.IDX function which only
> returns 1 column wide of INDEXES, that is pointers to the indices of the
> 'rows'
> as if they were sorted. It's a very powerful function.
>
> Regards,
>
> Daniel M.
>
>

[Tom Ogilvy]

assume the indexes are in a 1 based array named arrIdx

msgbox arr(arrIdx(5)-1,7)

will return the 5th item/row, 8th column from the original array as if it
had been sorted.

This assumes the 1 based array holds index numbers as if the original array
were 1-based. If not, then remove the -1.

--
Regards,
Tom Ogilvy

"RB Smissaert" <[email protected]> wrote in message
news:[email protected]...
> I have come across one major problem and that is that the VSORT routine
> will change 0-based arrays to 1-based arrays. I have searched everywhere
> about this, but couldn't find anything about it. I have e-mailed Laurent
> Longre
> and maybe he can help out.
> Had a look at the help about VSORT.IDX, but not sure how it would help me
> sorting a 2-D array, particularly an 0-based 2-D array where I want to
keep
> the
> base at 0.
>
> RBS
>
>
> "Daniel.M" <[email protected]> wrote in message
> news:[email protected]...
> > Hi,
> >
> >> I think I worked this all out now.
> >> Although it will need making an extra (the array holding the values to
> >> sort
> >> on)
> >
> > You could assign to new array sorted to the old one (depending on your
> > needs).
> > arr = VSORTArray(arr,...)
> >
> > Note that in cases of big arrays to sort and depending on the problem
(you
> > know,
> > I don't), it might be a good idea to look at VSORT.IDX function which
only
> > returns 1 column wide of INDEXES, that is pointers to the indices of the
> > 'rows'
> > as if they were sorted. It's a very powerful function.
> >
> > Regards,
> >
> > Daniel M.
> >
> >
>

[RB Smissaert]

Tom,

I had worked it out now.
The VSORT.IDX function does the trick.
This is my wrapper function for this now and it works fine:


Function VSORT_IDX_Array(ByRef arr As Variant, _
ByVal btCol1 As Byte, _
ByVal strSortType1 As String, _
Optional ByVal btCol2 As Byte = 0, _
Optional ByVal strSortType2 As String = "", _
Optional ByVal btCol3 As Byte = 0, _
Optional ByVal strSortType3 As String = "") As
Variant

'------------------------------------------------------------------
'http://longre.free.fr/english/
'Uses Laurent Longre's VSORT.IDX function in the .xll add-in MoreFunc
'Done up to 3 columns here, but can be done up to 14 columns
'------------------------------------------------------------------
'will sort an 0-based or 1-based 2-D array with up to 3 sort keys
'the field key has to be supplied as a byte, where the first column
'of the array is 1, even if it is an 0-based array
'the sort type has to be given as "a", "A" , "b" or "B"
'examples:
'sorting on 1 field: arr2 = VSORT_IDX_Array(arr, 1, "A")
'sorting on 2 fields: arr2 = VSORT_IDX_Array(arr, 2, "D", 5, "A")
'------------------------------------------------------------------

Dim i As Long
Dim c As Long
Dim LB1 As Long
Dim UB1 As Long
Dim LB2 As Long
Dim UB2 As Long
Dim arrKey1
Dim arrKey2
Dim arrKey3
Dim btSortType1 As Byte
Dim btSortType2 As Byte
Dim btSortType3 As Byte
Dim arrIndex
Dim arrFinal

LB1 = LBound(arr)
UB1 = UBound(arr)
LB2 = LBound(arr, 2)
UB2 = UBound(arr, 2)

ReDim arrFinal(LB1 To UB1, LB2 To UB2)

'make the array for key 1
'------------------------
ReDim arrKey1(LB1 To UB1, LB1 To LB1)
For i = LB1 To UB1
arrKey1(i, LB1) = arr(i, btCol1 - (1 - LB1))
Next

'set the sort type for key 1
'---------------------------
If UCase(strSortType1) = "A" Then
btSortType1 = 1
Else
btSortType1 = 0
End If

If Not btCol2 = 0 Then
'make the array for key 2
'------------------------
ReDim arrKey2(LB1 To UB1, LB1 To LB1)

For i = LB1 To UB1
arrKey2(i, LB1) = arr(i, btCol2 - (1 - LB1))
Next

'set the sort type for key 2
'---------------------------
If UCase(strSortType2) = "A" Then
btSortType2 = 1
Else
btSortType2 = 0
End If
End If

If Not btCol3 = 0 Then
'make the array for key 3
'------------------------
ReDim arrKey3(LB1 To UB1, LB1 To LB1)
For i = LB1 To UB1
arrKey3(i, LB1) = arr(i, btCol3 - (1 - LB1))
Next

'set the sort type for key 3
'---------------------------
If UCase(strSortType3) = "A" Then
btSortType3 = 1
Else
btSortType3 = 0
End If
End If

If Not btCol3 = 0 Then
'3 fields to sort on
'-------------------
arrIndex = Application.Run([VSORT.IDX], _
arrKey1, btSortType1, _
arrKey2, btSortType2, _
arrKey3, btSortType3)
Else
'2 fields to sort on
'-------------------
If Not btCol2 = 0 Then
arrIndex = Application.Run([VSORT.IDX], _
arrKey1, btSortType1, _
arrKey2, btSortType2)
Else
'1 field to sort on
'------------------
arrIndex = Application.Run([VSORT.IDX], _
arrKey1, btSortType1)
End If
End If

For i = LBound(arrIndex) To UBound(arrIndex)
For c = LB2 To UB2
arrFinal(i - (1 - LB1), c) = arr(arrIndex(i, 1) - (1 - LB1), c)
Next
Next

VSORT_IDX_Array = arrFinal

End Function

Just looking at this, perhaps I might as well use the VSORT function as I
have to transfer the array
now anyhow. If I use the VSORT I can avoid doing the array transfer if a
1-based array was given, thereby
speeding this up a bit.
I think the speed gain is not 4 to 5 times as my test was not up to scratch.
Seems more like 50% faster.
Still, it is easy to sort on multiple fields.


RBS


"Tom Ogilvy" <[email protected]> wrote in message
news:[email protected]...
> assume the indexes are in a 1 based array named arrIdx
>
> msgbox arr(arrIdx(5)-1,7)
>
> will return the 5th item/row, 8th column from the original array as if it
> had been sorted.
>
> This assumes the 1 based array holds index numbers as if the original
> array
> were 1-based. If not, then remove the -1.
>
> --
> Regards,
> Tom Ogilvy
>
> "RB Smissaert" <[email protected]> wrote in message
> news:[email protected]...
>> I have come across one major problem and that is that the VSORT routine
>> will change 0-based arrays to 1-based arrays. I have searched everywhere
>> about this, but couldn't find anything about it. I have e-mailed Laurent
>> Longre
>> and maybe he can help out.
>> Had a look at the help about VSORT.IDX, but not sure how it would help me
>> sorting a 2-D array, particularly an 0-based 2-D array where I want to
> keep
>> the
>> base at 0.
>>
>> RBS
>>
>>
>> "Daniel.M" <[email protected]> wrote in message
>> news:[email protected]...
>> > Hi,
>> >
>> >> I think I worked this all out now.
>> >> Although it will need making an extra (the array holding the values to
>> >> sort
>> >> on)
>> >
>> > You could assign to new array sorted to the old one (depending on your
>> > needs).
>> > arr = VSORTArray(arr,...)
>> >
>> > Note that in cases of big arrays to sort and depending on the problem
> (you
>> > know,
>> > I don't), it might be a good idea to look at VSORT.IDX function which
> only
>> > returns 1 column wide of INDEXES, that is pointers to the indices of
>> > the
>> > 'rows'
>> > as if they were sorted. It's a very powerful function.
>> >
>> > Regards,
>> >
>> > Daniel M.
>> >
>> >
>>
>
>

[RB Smissaert]

This will be faster if it is a 1-based array:


Function VSORTArray(ByRef arr As Variant, _
ByVal btCol1 As Byte, _
ByVal strSortType1 As String, _
Optional ByVal btCol2 As Byte = 0, _
Optional ByVal strSortType2 As String = "", _
Optional ByVal btCol3 As Byte = 0, _
Optional ByVal strSortType3 As String = "") As Variant

'------------------------------------------------------------------
'http://longre.free.fr/english/
'Uses Laurent Longre's VSort function in the .xll add-in MoreFunc
'Will be about 4 to 5 times faster than a quicksort and can sort
'on multiple columns.
'Done up to 3 columns here, but can be done up to 14 columns
'------------------------------------------------------------------
'will sort an 0-based or 1-based 2-D array with up to 3 sort keys
'the field key has to be supplied as a byte, where the first column
'of the array is 1, even if it is an 0-based array
'the sort type has to be given as "a", "A" , "b" or "B"
'examples:
'sorting on 1 field: arr2 = VSORTArray(arr, 1, "A")
'sorting on 2 fields: arr2 = VSORTArray(arr, 2, "D", 5, "A")
'------------------------------------------------------------------

Dim i As Long
Dim c As Long
Dim LB1 As Long
Dim UB1 As Long
Dim LB2 As Long
Dim UB2 As Long
Dim arrKey1
Dim arrKey2
Dim arrKey3
Dim btSortType1 As Byte
Dim btSortType2 As Byte
Dim btSortType3 As Byte
Dim arrFinal
Dim arrFinal2

LB1 = LBound(arr)
UB1 = UBound(arr)
LB2 = LBound(arr, 2)
UB2 = UBound(arr, 2)

'make the array for key 1
'------------------------
ReDim arrKey1(LB1 To UB1, LB1 To LB1)
For i = LB1 To UB1
arrKey1(i, LB1) = arr(i, btCol1 - (1 - LB1))
Next

'set the sort type for key 1
'---------------------------
If UCase(strSortType1) = "A" Then
btSortType1 = 1
Else
btSortType1 = 0
End If

If Not btCol2 = 0 Then
'make the array for key 2
'------------------------
ReDim arrKey2(LB1 To UB1, LB1 To LB1)

For i = LB1 To UB1
arrKey2(i, LB1) = arr(i, btCol2 - (1 - LB1))
Next

'set the sort type for key 2
'---------------------------
If UCase(strSortType2) = "A" Then
btSortType2 = 1
Else
btSortType2 = 0
End If
End If

If Not btCol3 = 0 Then
'make the array for key 3
'------------------------
ReDim arrKey3(LB1 To UB1, LB1 To LB1)
For i = LB1 To UB1
arrKey3(i, LB1) = arr(i, btCol3 - (1 - LB1))
Next

'set the sort type for key 3
'---------------------------
If UCase(strSortType3) = "A" Then
btSortType3 = 1
Else
btSortType3 = 0
End If
End If

If Not strSortType3 = "" Then
'3 fields to sort on
'-------------------
arrFinal = Application.Run([VSORT], arr, _
arrKey1, btSortType1, _
arrKey2, btSortType2, _
arrKey3, btSortType3)
Else
'2 fields to sort on
'-------------------
If Not strSortType2 = "" Then
arrFinal = Application.Run([VSORT], arr, _
arrKey1, btSortType1, _
arrKey2, btSortType2)
Else
'1 field to sort on
'------------------
arrFinal = Application.Run([VSORT], _
arr, arrKey1, btSortType1)
End If
End If

If LB1 = 0 Then
'to revert back to an 0-based array
'----------------------------------
ReDim arrFinal2(LB1 To UB1, LB2 To UB2)
For i = LBound(arrFinal) To UBound(arrFinal)
For c = LBound(arrFinal, 2) To UBound(arrFinal, 2)
arrFinal2(i - (1 - LB1), c - (1 - LB2)) = arrFinal(i, c)
Next
Next
VSORTArray = arrFinal2
Else
VSORTArray = arrFinal
End If

End Function

One thing I noticed that the number of rows in the array to sort can't go
above 65536, the number of rows in the sheet.
It seems that these functions are geared towards sheet ranges (always
produce 1-based arrays, limit of 65536 rows)
even though they can be used for arrays. The benefit speedwise would come
into play with arrays larger than this, unless maybe you have slow hardware.
The main benefit though is that you can sort on multiple fields.


RBS


"Tom Ogilvy" <[email protected]> wrote in message
news:[email protected]...
> assume the indexes are in a 1 based array named arrIdx
>
> msgbox arr(arrIdx(5)-1,7)
>
> will return the 5th item/row, 8th column from the original array as if it
> had been sorted.
>
> This assumes the 1 based array holds index numbers as if the original
> array
> were 1-based. If not, then remove the -1.
>
> --
> Regards,
> Tom Ogilvy
>
> "RB Smissaert" <[email protected]> wrote in message
> news:[email protected]...
>> I have come across one major problem and that is that the VSORT routine
>> will change 0-based arrays to 1-based arrays. I have searched everywhere
>> about this, but couldn't find anything about it. I have e-mailed Laurent
>> Longre
>> and maybe he can help out.
>> Had a look at the help about VSORT.IDX, but not sure how it would help me
>> sorting a 2-D array, particularly an 0-based 2-D array where I want to
> keep
>> the
>> base at 0.
>>
>> RBS
>>
>>
>> "Daniel.M" <[email protected]> wrote in message
>> news:[email protected]...
>> > Hi,
>> >
>> >> I think I worked this all out now.
>> >> Although it will need making an extra (the array holding the values to
>> >> sort
>> >> on)
>> >
>> > You could assign to new array sorted to the old one (depending on your
>> > needs).
>> > arr = VSORTArray(arr,...)
>> >
>> > Note that in cases of big arrays to sort and depending on the problem
> (you
>> > know,
>> > I don't), it might be a good idea to look at VSORT.IDX function which
> only
>> > returns 1 column wide of INDEXES, that is pointers to the indices of
>> > the
>> > 'rows'
>> > as if they were sorted. It's a very powerful function.
>> >
>> > Regards,
>> >
>> > Daniel M.
>> >
>> >
>>
>
>

[bbrock]

I made this up to sort a 1-D array but I think one can extrapolate it to a 2-D. It is short and sweet and I left comments and extra code in their so that it is easily understood. I hope this helps. I tried to hash through the Laurent Longre's code but it was too much to read so I wrote this...not that this is better.




Sub sort() ***You can convert it to a function with a little code***

Dim Vary() ' THIS ARRAY CONTAINS THE VALUES TO BE SORTED
Dim Dary() ' VARY() VALUE DESCRIPTIONS
Dim Sary() ' NEW SORTED ARRAY (FINAL PRODUCT)
Dim newVAry() ' SAME AS VARY() BUT LESS THE MAX VALUE
Dim newDAry() ' SAME AS DARY() BUT LESS THE DESC OF THE MAX VALUE
Dim SubVAry() ' SAME AS VARY() BUT ONE DIMENSION
Dim SubDAry() ' SAME AS DARY() BUT ONE DIMENSION

' HERE I HAD TO 1-D ARRAYS HOWEVER YOU CAN CONVERT IT TO A SINGLE 2-D
' BY THE WAY RNG AND RNG2 ARE TWO CORRESPONDING RANGES SAME ROWS BUT
' DIFFERENT COLUMNS
' EXAMPLE: RNG = "C1:C100", RNG2 = "D1:D100"


Vary() = ActiveSheet.Range(rng).Value
Dary() = ActiveSheet.Range(rng2).Value

ReDim Sary(UBound(Vary()))

k = 1 ' SIZE OF THE FINAL ARRAY
j = 1 ' SIZE OF THE NEW ARRAY WITHOUT THE MAX VALUES
ReDim Sary(2, 1) '(DESC, VALUE)
ReDim SubVAry(1) ' INITIALIZE
ReDim SubDAry(1) ' INITIALIZE

' REDIMENSIONALIZE THE ORIGINAL ARRAYS
For i = 1 To UBound(Vary())
ReDim Preserve SubVAry(i)
ReDim Preserve SubDAry(i)
SubVAry(i) = Vary(i, 1)
SubDAry(i) = Dary(i, 1)
Next i

99
maxAry = Application.WorksheetFunction.Max(SubVAry())
' IF THE MAX OF THE REMAINING VALUES OF THE ARRAY ARE ZERO THEN QUIT
If maxAry = 0 Then
GoTo 100
End If

For i = 1 To UBound(SubVAry())
If SubVAry(i) = maxAry Then
vals = SubVAry(i)
desc = SubDAry(i)
ReDim Preserve Sary(2, k)
Sary(1, k) = desc
Sary(2, k) = vals
k = k + 1
' THE INDEX VALUE OF THE ARRAY ISN'T THE MAX OF THE ARRAY
' THEN PUT THOSE VALUES IN A SEPARATE DISCARDED ARRAY
Else:
ReDim Preserve newVAry(j)
ReDim Preserve newDAry(j)
newVAry(j) = SubVAry(i)
newDAry(j) = SubDAry(i)
j = j + 1
End If
Next i
' SET THE ORIGINAL 1-D ARRAY = TO THE VALUES IN THE DISCARDED ARRAY
SubVAry() = newVAry()
SubDAry() = newDAry()
j = 1
'START OVER WITH THE DISCARDED ARRAY
GoTo 99

' FINALLY JUST PUT THE VALUES ON THE WORKSHEET
100
For i = 1 To k - 1
ActiveSheet.Cells(i + 2, 30) = Sary(1, i)
ActiveSheet.Cells(i + 2, 31) = Sary(2, i)
Next i


End Sub

Brian