Attribute VB_Name = "MerriSort" ' MerriSort.bas - speed optimized median three QuickSort ' array types supported: Boolean, Byte, Currency, Date, Double, Integer, Long, Single, String ' ' Boolean, Byte & Integer sorted using CountSort (faster for large arrays) ' Date & Double sorted using QuickSort with Double datatype ' ' usage: QSort Not Not YourArrayVariable Option Explicit Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Arr() As Any) As Long Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Ptr As Long, ByVal Value As Long) Private Type StrArrType S() As String End Type ' for comparison: original Variant version by Ellis Dee @ http://www.vbforums.com/showpost.php?p=2909260&postcount=14 Public Sub MedianThreeQuickSort1(ByRef pvarArray As Variant, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long) Dim lngFirst As Long Dim lngLast As Long Dim varMid As Variant Dim lngIndex As Long Dim varSwap As Variant Dim A As Long Dim B As Long Dim C As Long If plngRight = 0 Then plngLeft = LBound(pvarArray) plngRight = UBound(pvarArray) End If lngFirst = plngLeft lngLast = plngRight lngIndex = plngRight - plngLeft + 1 A = Int(lngIndex * Rnd) + plngLeft B = Int(lngIndex * Rnd) + plngLeft C = Int(lngIndex * Rnd) + plngLeft If pvarArray(A) <= pvarArray(B) And pvarArray(B) <= pvarArray(C) Then lngIndex = B Else If pvarArray(B) <= pvarArray(A) And pvarArray(A) <= pvarArray(C) Then lngIndex = A Else lngIndex = C End If End If varMid = pvarArray(lngIndex) Do Do While pvarArray(lngFirst) < varMid And lngFirst < plngRight lngFirst = lngFirst + 1 Loop Do While varMid < pvarArray(lngLast) And lngLast > plngLeft lngLast = lngLast - 1 Loop If lngFirst <= lngLast Then varSwap = pvarArray(lngFirst) pvarArray(lngFirst) = pvarArray(lngLast) pvarArray(lngLast) = varSwap lngFirst = lngFirst + 1 lngLast = lngLast - 1 End If Loop Until lngFirst > lngLast If lngLast - plngLeft < plngRight - lngFirst Then If plngLeft < lngLast Then MedianThreeQuickSort1 pvarArray, plngLeft, lngLast If lngFirst < plngRight Then MedianThreeQuickSort1 pvarArray, lngFirst, plngRight Else If lngFirst < plngRight Then MedianThreeQuickSort1 pvarArray, lngFirst, plngRight If plngLeft < lngLast Then MedianThreeQuickSort1 pvarArray, plngLeft, lngLast End If End Sub Public Sub QSort(ByVal NotNotArray As Long) Dim A() As Long, AH(0 To 5) As Long, AP As Long Dim ArrayBase As Long, H As Long, J As Long, K As Long, R As Long ' VB6 IDE bug with Not ArrayName, this fixes it Debug.Assert App.hInstance ' did we get any pointer? If NotNotArray Then ' is the pointer negative or positive? If NotNotArray < 0 Then R = -4 Else R = 4 ' yippee, now lets check it out AH(0) = 1: AH(1) = 4: AH(3) = NotNotArray - R: AH(4) = &H3FFFFFFF ' start safe array hack using the header created in above line AP = ArrPtr(A): PutMem4 AP, VarPtr(AH(0)) ' first of all: we must have datatype defined and the array must be one dimensional If (A(1) And &H80FFFF) = &H800001 Then ' does it have any items? If A(5) > 0 Then ' remember old base & force zero base! ArrayBase = A(6): A(6) = 0 ' check out the datatype! Select Case A(0) Case vbBoolean, vbInteger ' count sort is the fastest here! Dim I() As Integer, IC As Integer, ICount(&H8000 To &H7FFF) As Long ' get I variable pointer and position our array at it AH(3) = ArrPtr(I): A(0) = NotNotArray ' start counting! For H = 0 To UBound(I) ' get byte value IC = I(H) ' increase counter for that value ICount(IC) = ICount(IC) + 1 Next H ' now loop through and change things For H = &H8000 To &H7FFF ' we cannot use a Integer in the loop so convert long to byte IC = H ' now loop through the count to zero For J = ICount(H) To 1 Step -1 ' change to the current byte I(K) = IC ' increase kounter K = K + 1 Next J Next H ' release I from the safe array header A(0) = 0 Case vbByte ' count sort is the fastest here! Dim B() As Byte, BC As Byte, BCount(0 To 255) As Long ' get B variable pointer and position our array at it AH(3) = ArrPtr(B): A(0) = NotNotArray ' start counting! For H = 0 To UBound(B) ' get byte value BC = B(H) ' increase counter for that value BCount(BC) = BCount(BC) + 1 Next H ' now loop through and change things For H = 0 To 255 ' we cannot use a Byte in the loop so convert long to byte BC = H ' now loop through the count to zero For J = BCount(H) To 1 Step -1 ' change to the current byte B(K) = BC ' increase kounter K = K + 1 Next J Next H ' release B from the safe array header A(0) = 0 Case vbCurrency Dim C() As Currency ' get C variable pointer and place safe array header there AH(3) = ArrPtr(C): A(0) = NotNotArray ' do the sort QSortCurrency C, 0, UBound(C), Rnd, Rnd, Rnd ' release C from the safe array header A(0) = 0 Case vbDate, vbDouble Dim D() As Double ' get D variable pointer and place safe array header there AH(3) = ArrPtr(D): A(0) = NotNotArray ' do the sort QSortDouble D, 0, UBound(D), Rnd, Rnd, Rnd ' release D from the safe array header A(0) = 0 Case vbLong Dim L() As Long ' get L variable pointer and place safe array header there AH(3) = ArrPtr(L): A(0) = NotNotArray ' do the sort QSortLong L, 0, UBound(L), Rnd, Rnd, Rnd ' release L from the safe array header A(0) = 0 Case vbSingle Dim S() As Single ' get S variable pointer and place safe array header there AH(3) = ArrPtr(S): A(0) = NotNotArray ' do the sort QSortSingle S, 0, UBound(S), Rnd, Rnd, Rnd ' release S from the safe array header A(0) = 0 Case vbString ' we cannot use ArrPtr on a string array, so... use UDT to trick our way out of it! Dim StrArr As StrArrType, SP As Long ' get variable pointer and place safe array header there SP = VarPtr(StrArr): AH(3) = SP: A(0) = NotNotArray ' then get the pointer so that A points to the same data StrArr.S points to AH(3) = NotNotArray: AH(3) = A(3) ' do the sort QSortString StrArr.S, A, 0, UBound(StrArr.S), Rnd, Rnd, Rnd ' release StrPtr.S from safe array header AH(3) = SP: A(0) = 0 Case Else ' restore everything & cleanup! AH(3) = NotNotArray - R A(6) = ArrayBase AH(3) = AP: A(0) = 0 ' now raise an error... Err.Raise 5, "MerriSort.QSort", "Invalid array datatype (must be Boolean, Byte, Currency, Date, Double, Integer, Long, Single or String)" ' in case somebody uses error trapping Exit Sub End Select ' restore original base AH(3) = NotNotArray - R A(6) = ArrayBase End If End If ' end safe array hack AH(3) = AP: A(0) = 0 End If End Sub Private Sub QSortCurrency(Arr() As Currency, ByVal Left As Long, ByVal Right As Long, ByVal RndA As Double, ByVal RndB As Double, ByVal RndC As Double) Dim Index As Long, First As Long, Last As Long, Middle As Currency, Swap As Currency Dim A As Long, B As Long, C As Long First = Left Last = Right Index = Right - Left + 1 A = CLng(Int(RndA * Index)) + Left B = CLng(Int(RndB * Index)) + Left C = CLng(Int(RndC * Index)) + Left If Arr(A) <= Arr(B) And Arr(B) <= Arr(C) Then Index = B Else If Arr(B) <= Arr(A) And Arr(A) <= Arr(C) Then Index = A Else Index = C End If End If Middle = Arr(Index) Do Do While Arr(First) < Middle And First < Right First = First + 1 Loop Do While Middle < Arr(Last) And Last > Left Last = Last - 1 Loop If First <= Last Then Swap = Arr(First) Arr(First) = Arr(Last) Arr(Last) = Swap First = First + 1 Last = Last - 1 End If Loop Until First > Last If Last - Left < Right - First Then If Left < Last Then QSortCurrency Arr, Left, Last, RndA, RndB, RndC If First < Right Then QSortCurrency Arr, First, Right, RndA, RndB, RndC Else If First < Right Then QSortCurrency Arr, First, Right, RndA, RndB, RndC If Left < Last Then QSortCurrency Arr, Left, Last, RndA, RndB, RndC End If End Sub Private Sub QSortDouble(Arr() As Double, ByVal Left As Long, ByVal Right As Long, ByVal RndA As Double, ByVal RndB As Double, ByVal RndC As Double) Dim Index As Long, First As Long, Last As Long, Middle As Double, Swap As Double Dim A As Long, B As Long, C As Long First = Left Last = Right Index = Right - Left + 1 A = CLng(Int(RndA * Index)) + Left B = CLng(Int(RndB * Index)) + Left C = CLng(Int(RndC * Index)) + Left If Arr(A) <= Arr(B) And Arr(B) <= Arr(C) Then Index = B Else If Arr(B) <= Arr(A) And Arr(A) <= Arr(C) Then Index = A Else Index = C End If End If Middle = Arr(Index) Do Do While Arr(First) < Middle And First < Right First = First + 1 Loop Do While Middle < Arr(Last) And Last > Left Last = Last - 1 Loop If First <= Last Then Swap = Arr(First) Arr(First) = Arr(Last) Arr(Last) = Swap First = First + 1 Last = Last - 1 End If Loop Until First > Last If Last - Left < Right - First Then If Left < Last Then QSortDouble Arr, Left, Last, RndA, RndB, RndC If First < Right Then QSortDouble Arr, First, Right, RndA, RndB, RndC Else If First < Right Then QSortDouble Arr, First, Right, RndA, RndB, RndC If Left < Last Then QSortDouble Arr, Left, Last, RndA, RndB, RndC End If End Sub Private Sub QSortLong(Arr() As Long, ByVal Left As Long, ByVal Right As Long, ByVal RndA As Double, ByVal RndB As Double, ByVal RndC As Double) Dim Index As Long, First As Long, Last As Long, Middle As Long, Swap As Long Dim A As Long, B As Long, C As Long First = Left Last = Right Index = Right - Left + 1 A = CLng(Int(RndA * Index)) + Left B = CLng(Int(RndB * Index)) + Left C = CLng(Int(RndC * Index)) + Left If Arr(A) <= Arr(B) And Arr(B) <= Arr(C) Then Index = B Else If Arr(B) <= Arr(A) And Arr(A) <= Arr(C) Then Index = A Else Index = C End If End If Middle = Arr(Index) Do Do While Arr(First) < Middle And First < Right First = First + 1 Loop Do While Middle < Arr(Last) And Last > Left Last = Last - 1 Loop If First <= Last Then Swap = Arr(First) Arr(First) = Arr(Last) Arr(Last) = Swap First = First + 1 Last = Last - 1 End If Loop Until First > Last If Last - Left < Right - First Then If Left < Last Then QSortLong Arr, Left, Last, RndA, RndB, RndC If First < Right Then QSortLong Arr, First, Right, RndA, RndB, RndC Else If First < Right Then QSortLong Arr, First, Right, RndA, RndB, RndC If Left < Last Then QSortLong Arr, Left, Last, RndA, RndB, RndC End If End Sub Private Sub QSortSingle(Arr() As Single, ByVal Left As Long, ByVal Right As Long, ByVal RndA As Double, ByVal RndB As Double, ByVal RndC As Double) Dim Index As Long, First As Long, Last As Long, Middle As Single, Swap As Single Dim A As Long, B As Long, C As Long First = Left Last = Right Index = Right - Left + 1 A = CLng(Int(RndA * Index)) + Left B = CLng(Int(RndB * Index)) + Left C = CLng(Int(RndC * Index)) + Left If Arr(A) <= Arr(B) And Arr(B) <= Arr(C) Then Index = B Else If Arr(B) <= Arr(A) And Arr(A) <= Arr(C) Then Index = A Else Index = C End If End If Middle = Arr(Index) Do Do While Arr(First) < Middle And First < Right First = First + 1 Loop Do While Middle < Arr(Last) And Last > Left Last = Last - 1 Loop If First <= Last Then Swap = Arr(First) Arr(First) = Arr(Last) Arr(Last) = Swap First = First + 1 Last = Last - 1 End If Loop Until First > Last If Last - Left < Right - First Then If Left < Last Then QSortSingle Arr, Left, Last, RndA, RndB, RndC If First < Right Then QSortSingle Arr, First, Right, RndA, RndB, RndC Else If First < Right Then QSortSingle Arr, First, Right, RndA, RndB, RndC If Left < Last Then QSortSingle Arr, Left, Last, RndA, RndB, RndC End If End Sub Private Sub QSortString(Arr() As String, ArrL() As Long, ByVal Left As Long, ByVal Right As Long, ByVal RndA As Double, ByVal RndB As Double, ByVal RndC As Double) Dim Index As Long, First As Long, Last As Long, Middle As String, Swap As Long Dim A As Long, B As Long, C As Long First = Left Last = Right Index = Right - Left + 1 A = CLng(Int(RndA * Index)) + Left B = CLng(Int(RndB * Index)) + Left C = CLng(Int(RndC * Index)) + Left If Arr(A) <= Arr(B) And Arr(B) <= Arr(C) Then Index = B Else If Arr(B) <= Arr(A) And Arr(A) <= Arr(C) Then Index = A Else Index = C End If End If Middle = Arr(Index) Do Do While Arr(First) < Middle And First < Right First = First + 1 Loop Do While Middle < Arr(Last) And Last > Left Last = Last - 1 Loop If First <= Last Then Swap = ArrL(First) ArrL(First) = ArrL(Last) ArrL(Last) = Swap First = First + 1 Last = Last - 1 End If Loop Until First > Last If Last - Left < Right - First Then If Left < Last Then QSortString Arr, ArrL, Left, Last, RndA, RndB, RndC If First < Right Then QSortString Arr, ArrL, First, Right, RndA, RndB, RndC Else If First < Right Then QSortString Arr, ArrL, First, Right, RndA, RndB, RndC If Left < Last Then QSortString Arr, ArrL, Left, Last, RndA, RndB, RndC End If End Sub