VBA Sort RossetaCode

Public Sub Quick(a() As Variant, last As Integer)
' quicksort a Variant array (1-based, numbers or strings)
Dim aLess() As Variant
Dim aEq() As Variant
Dim aGreater() As Variant
Dim pivot As Variant
Dim naLess As Integer
Dim naEq As Integer
Dim naGreater As Integer
 
If last > 1 Then
    'choose pivot in the middle of the array
    pivot = a(Int((last + 1) / 2))
    'construct arrays
    naLess = 0
    naEq = 0
    naGreater = 0
    For Each el In a()
      If el > pivot Then
        naGreater = naGreater + 1
        ReDim Preserve aGreater(1 To naGreater)
        aGreater(naGreater) = el
      ElseIf el < pivot Then
        naLess = naLess + 1
        ReDim Preserve aLess(1 To naLess)
        aLess(naLess) = el
      Else
        naEq = naEq + 1
        ReDim Preserve aEq(1 To naEq)
        aEq(naEq) = el
      End If
    Next
    'sort arrays "less" and "greater"
    Quick aLess(), naLess
    Quick aGreater(), naGreater
    'concatenate
    P = 1
    For i = 1 To naLess
      a(P) = aLess(i): P = P + 1
    Next
    For i = 1 To naEq
      a(P) = aEq(i): P = P + 1
    Next
    For i = 1 To naGreater
      a(P) = aGreater(i): P = P + 1
    Next
End If
End Sub
 
Public Sub QuicksortTest()
Dim a(1 To 26) As Variant
 
 'populate a with numbers in descending order, then sort
 For i = 1 To 26: a(i) = 26 - i: Next
 Quick a(), 26
 For i = 1 To 26: Debug.Print a(i);: Next
 Debug.Print
 'now populate a with strings in descending order, then sort
 For i = 1 To 26: a(i) = Chr$(Asc("z") + 1 - i) & "-stuff": Next
 Quick a(), 26
 For i = 1 To 26: Debug.Print a(i); " ";: Next
 Debug.Print
End Sub

Source: rosettacode.org

Similar codes

0 vote140 views1 answer
Vbnet add new ecel sheet
VBA
0 vote164 views1 answer
(SecurityProtocolType)3072 vb.net
VBA
0 vote140 views1 answer
Vba argument is set
VBA
18 votes328 views2 answers
Vba make word from bytes
VBA
0 vote166 views1 answer
Sendkeys vba selenium
VBA
8 votes235 views1 answer
Excel vba determine number of elements in a 2D array
VBA
0 vote158 views1 answer
Vba collection contains
VBA
0 vote150 views1 answer
Excel vba ternary
VBA
0 vote147 views1 answer
Vba verticalalignment
VBA
0 vote149 views1 answer
Afficher un message d'erreur vba
VBA