ExcelBanter - Array sorting

If you really want very fast performance to sort a 1-D string array then use
a routine I got from Olaf Schmidt. This works with pointers.

I post the full code, including a timer so you can see the difference in
speed.
I know your arrays are very small, so no gain for you, but other users of
this forum might be interested in this.

Option Explicit
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private lStartTime As Long
'================================================= =====
'this is just to make it clear what we are dealing with
'================================================= =====
Private Type SAFEARRAYBOUND
cElements As Long ' +16
lLbound As Long ' +20
End Type

Private Type SAFEARRAY1D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
cElements As Long
lLbound As Long
End Type

Private Declare Sub BindArray Lib "kernel32" Alias "RtlMoveMemory" _
(PArr() As Any, pSrc&, _
Optional ByVal cb& = 4)
Private Declare Sub ReleaseArray Lib "kernel32" Alias "RtlMoveMemory" _
(PArr() As Any, _
Optional pSrc& = 0, _
Optional ByVal cb& = 4)

Function QuickSortStringAsc(arrString() As String, _
Optional lLow1 = -1, _
Optional lhigh1 = -1)

Dim lLow2 As Long
Dim lhigh2 As Long
Dim strVal1 As String
Dim strVal2 As String

'If first time, get the size of the array to sort
If lLow1 = -1 Then
lLow1 = LBound(arrString, 1)
End If

If lhigh1 = -1 Then
lhigh1 = UBound(arrString, 1)
End If

'Set new extremes to old extremes
lLow2 = lLow1
lhigh2 = lhigh1

'Get value of array item in middle of new extremes
strVal1 = arrString((lLow1 + lhigh1) / 2)

'Loop for all the items in the array between the extremes
While (lLow2 <= lhigh2)

'Find the first item that is greater than the mid-point item
While (arrString(lLow2) < strVal1 And lLow2 < lhigh1)
lLow2 = lLow2 + 1
Wend

'Find the last item that is less than the mid-point item
While (arrString(lhigh2) strVal1 And lhigh2 lLow1)
lhigh2 = lhigh2 - 1
Wend

'If the new 'greater' item comes before the new 'less' item, swap them
If (lLow2 <= lhigh2) Then
strVal2 = arrString(lLow2)
arrString(lLow2) = arrString(lhigh2)
arrString(lhigh2) = strVal2

'Advance the pointers to the next item
lLow2 = lLow2 + 1
lhigh2 = lhigh2 - 1
End If
Wend

'Iterate to sort the lower half of the extremes
If (lhigh2 lLow1) Then
QuickSortStringAsc arrString, lLow1, lhigh2
End If

'Iterate to sort the upper half of the extremes
If (lLow2 < lhigh1) Then
QuickSortStringAsc arrString, lLow2, lhigh1
End If

QuickSortStringAsc = arrString

End Function

Function QuickSortStringDesc(arrString() As String, _
Optional lLow1 = -1, _
Optional lhigh1 = -1)

Dim lLow2 As Long
Dim lhigh2 As Long
Dim strVal1 As String
Dim strVal2 As String

'If first time, get the size of the array to sort
If lLow1 = -1 Then
lLow1 = LBound(arrString, 1)
End If

If lhigh1 = -1 Then
lhigh1 = UBound(arrString, 1)
End If

'Set new extremes to old extremes
lLow2 = lLow1
lhigh2 = lhigh1

'Get value of array item in middle of new extremes
strVal1 = arrString((lLow1 + lhigh1) / 2)

'Loop for all the items in the array between the extremes
While (lLow2 <= lhigh2)

'Find the first item that is greater than the mid-point item
While (arrString(lLow2) strVal1 And lLow2 < lhigh1)
lLow2 = lLow2 + 1
Wend

'Find the last item that is less than the mid-point item
While (arrString(lhigh2) < strVal1 And lhigh2 lLow1)
lhigh2 = lhigh2 - 1
Wend

'If the new 'greater' item comes before the new 'less' item, swap them
If (lLow2 <= lhigh2) Then
strVal2 = arrString(lLow2)
arrString(lLow2) = arrString(lhigh2)
arrString(lhigh2) = strVal2

'Advance the pointers to the next item
lLow2 = lLow2 + 1
lhigh2 = lhigh2 - 1
End If
Wend

'Iterate to sort the lower half of the extremes
If (lhigh2 lLow1) Then
QuickSortStringDesc arrString, lLow1, lhigh2
End If

'Iterate to sort the upper half of the extremes
If (lLow2 < lhigh1) Then
QuickSortStringDesc arrString, lLow2, lhigh1
End If

QuickSortStringDesc = arrString

End Function

Sub QSort1DStringArrayPAsc(arrString() As String)

Dim i As Long
Dim j As Long
Dim Lo As Long
Dim Hi As Long
Dim StPtr As Long
Dim V(0) As String
Dim pV() As Long
Dim sapV As SAFEARRAY1D
Dim PArr() As Long
Dim sapArr As SAFEARRAY1D
Dim p As Long
Dim StSize As Long
Dim StLo() As Long
Dim StHi() As Long

StSize = 255
ReDim StLo(StSize)
ReDim StHi(StSize) 'init the stack

On Error Resume Next
'spans a Long-Array (pArr()) over the StringPointers in Arr()
sapArr.cDims = 1
sapArr.cbElements = 4 'Bytes used by each StrPointer
sapArr.lLbound = LBound(arrString)
sapArr.pvData = VarPtr(arrString(sapArr.lLbound))
sapArr.cElements = UBound(arrString) - LBound(arrString) + 1

If Err Then
Err.Clear
Exit Sub 'Arr was not initialized
End If

On Error GoTo 0 'switch off Err-Handler for speed-reasons
BindArray PArr, VarPtr(sapArr)

'another Array, used to hold only one single String,
'respective its pointer for reasons of comparing inside the algo
sapV.cDims = 1
sapV.cbElements = 4
sapV.pvData = VarPtr(V(0))
sapV.cElements = 1
BindArray pV, VarPtr(sapV)

StPtr = 1 'init the StackPointer
StLo(0) = LBound(arrString)
StHi(0) = UBound(arrString)

Do
StPtr = StPtr - 1
Lo = StLo(StPtr)
Hi = StHi(StPtr)
If Hi - Lo < 12 Then 'MinSort
For Lo = Lo To Hi - 1
j = Lo
For i = Lo + 1 To Hi
If arrString(i) < arrString(j) Then j = i
Next i
If j < Lo Then
p = PArr(j): PArr(j) = PArr(Lo): PArr(Lo) = p
End If
Next Lo
Else 'QSort
Do
i = Lo: j = Hi
pV(0) = PArr((Lo + Hi) \ 2)
Do
Do While arrString(i) < V(0)
i = i + 1
Loop
Do While arrString(j) V(0)
j = j - 1
Loop
If i <= j Then
p = PArr(i)
PArr(i) = PArr(j)
PArr(j) = p
i = i + 1
j = j - 1
End If
Loop While i <= j

If j - Lo < Hi - i Then
If i < Hi Then
StLo(StPtr) = i
StHi(StPtr) = Hi
StPtr = StPtr + 1
If StPtr = StSize Then
StSize = StSize + StSize
ReDim Preserve StLo(StSize)
ReDim Preserve StHi(StSize)
End If
End If
Hi = j
Else
If Lo < j Then
StLo(StPtr) = Lo
StHi(StPtr) = j
StPtr = StPtr + 1
If StPtr = StSize Then
StSize = StSize + StSize
ReDim Preserve StLo(StSize)
ReDim Preserve StHi(StSize)
End If
End If
Lo = i
End If
Loop While Lo < Hi
End If
Loop While StPtr

pV(0) = 0 'don't dispose the current String-Content of V(0)
ReleaseArray pV 'release the Array-Mapping between V() and pV()
ReleaseArray PArr 'relase the Array-Mapping between Arr() and pArr()

End Sub

Sub QSort1DStringArrayPDesc(arrString() As String)

Dim i As Long
Dim j As Long
Dim Lo As Long
Dim Hi As Long
Dim StPtr As Long
Dim V(0) As String
Dim pV() As Long
Dim sapV As SAFEARRAY1D
Dim PArr() As Long
Dim sapArr As SAFEARRAY1D
Dim p As Long
Dim StSize As Long
Dim StLo() As Long
Dim StHi() As Long

StSize = 255
ReDim StLo(StSize)
ReDim StHi(StSize) 'init the stack

On Error Resume Next
'spans a Long-Array (pArr()) over the StringPointers in Arr()
sapArr.cDims = 1
sapArr.cbElements = 4 'Bytes used by each StrPointer
sapArr.lLbound = LBound(arrString)
sapArr.pvData = VarPtr(arrString(sapArr.lLbound))
sapArr.cElements = UBound(arrString) - LBound(arrString) + 1

If Err Then
Err.Clear
Exit Sub 'Arr was not initialized
End If

On Error GoTo 0 'switch off Err-Handler for speed-reasons
BindArray PArr, VarPtr(sapArr)

'another Array, used to hold only one single String,
'respective its pointer for reasons of comparing inside the algo
sapV.cDims = 1
sapV.cbElements = 4
sapV.pvData = VarPtr(V(0))
sapV.cElements = 1
BindArray pV, VarPtr(sapV)

StPtr = 1 'init the StackPointer
StLo(0) = LBound(arrString)
StHi(0) = UBound(arrString)

Do
StPtr = StPtr - 1
Lo = StLo(StPtr)
Hi = StHi(StPtr)
If Hi - Lo < 12 Then 'MinSort
For Lo = Lo To Hi - 1
j = Lo
For i = Lo + 1 To Hi
If arrString(i) arrString(j) Then j = i
Next i
If j < Lo Then
p = PArr(j): PArr(j) = PArr(Lo): PArr(Lo) = p
End If
Next Lo
Else 'QSort
Do
i = Lo: j = Hi
pV(0) = PArr((Lo + Hi) \ 2)
Do
Do While arrString(i) V(0)
i = i + 1
Loop
Do While arrString(j) < V(0)
j = j - 1
Loop
If i <= j Then
p = PArr(i)
PArr(i) = PArr(j)
PArr(j) = p
i = i + 1
j = j - 1
End If
Loop While i <= j

If j - Lo < Hi - i Then
If i < Hi Then
StLo(StPtr) = i
StHi(StPtr) = Hi
StPtr = StPtr + 1
If StPtr = StSize Then
StSize = StSize + StSize
ReDim Preserve StLo(StSize)
ReDim Preserve StHi(StSize)
End If
End If
Hi = j
Else
If Lo < j Then
StLo(StPtr) = Lo
StHi(StPtr) = j
StPtr = StPtr + 1
If StPtr = StSize Then
StSize = StSize + StSize
ReDim Preserve StLo(StSize)
ReDim Preserve StHi(StSize)
End If
End If
Lo = i
End If
Loop While Lo < Hi
End If
Loop While StPtr

pV(0) = 0 'don't dispose the current String-Content of V(0)
ReleaseArray pV 'release the Array-Mapping between V() and pV()
ReleaseArray PArr 'relase the Array-Mapping between Arr() and pArr()

End Sub

Sub test()

Dim i As Long
Dim arr() As String
Dim bSortDesc As Boolean
Dim bPointerSort As Boolean
Dim lUB As Long

lUB = 1000

'comment out variables here to alter the test routine
'----------------------------------------------------
'bSortDesc = True
bPointerSort = True

ReDim arr(lUB) As String

'to get random integer within range:
'Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
'-----------------------------------------------------
For i = 0 To lUB
'random characters between A and Z
arr(i) = Chr(Int(26 * Rnd + 65))
Next i

StartSW

If bSortDesc Then
If bPointerSort Then
QSort1DStringArrayPDesc arr
Else
arr = QuickSortStringDesc(arr)
End If
Else
If bPointerSort Then
QSort1DStringArrayPAsc arr
Else
arr = QuickSortStringAsc(arr)
End If
End If

StopSW

For i = 0 To lUB
Cells(i + 1, 1) = arr(i)
Next i

End Sub

Sub StartSW()
lStartTime = timeGetTime()
End Sub

Function StopSW(Optional bMsgBox As Boolean = True, _
Optional vMessage As Variant, _
Optional lMinimumTimeToShow As Long = -1) As Variant

Dim lTime As Long

lTime = timeGetTime() - lStartTime

If lTime lMinimumTimeToShow Then
If IsMissing(vMessage) Then
StopSW = lTime
Else
StopSW = lTime & " - " & vMessage
End If
End If

If bMsgBox Then
If lTime lMinimumTimeToShow Then
MsgBox "Done in " & lTime & " msecs", , vMessage
End If
End If

End Function

RBS

"Rivers" wrote in message
...
Hi guys is there a quick way to get an array that holds 30 names
alphabetically sorted. any help would be great. my array is called str(30)