This will work with both an 0-based array and a 1-based array:

Public Sub QSort1DStringArrayP(arrString() As String)

'Dim Compare 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

The declarations etc. are just the same as before.
It will be faster if you could code in VB6 (worth buying) as you have all
the fast compiler options
that are not available in VBA, but even in VBA this is very fast.


RBS



"Deke" wrote in message
...
Hi,

Thank for the reply. Got both the bits of code to work perfectly first
time. The VB script is a lot faster and is exactly what I'm needing, I've
got the processing time down from 20-30 min's to seconds.

Again, thank's for all your help, it was exactly what I was needing...

--
Cheers...


" wrote:

It is in fact a lot faster in VBA as well, have just tested.
It needs some adjustments though to work with a 1-based array, which
I haven't worked out yet. Fine though with a 0-based array.

RBS