Sort array in VBA

Question

I have a 182.123 size array and I want to sort them by an specific attribute of the class of the array. The class is called CFlujo and the property I want to sort them by is by a string called id_flujo. So far I'm doing a bubble sort like this but it just takes too long:

Sub sort_arreglo(arreglo As Variant)
For x = LBound(arreglo) To UBound(arreglo)
For y = x To UBound(arreglo)
    Dim aux As CFlujo
    aux = New CFlujo
  If UCase(arreglo(y).id_flujo) < UCase(arreglo(x).id_flujo) Then
    Set aux = arreglo(y)
    Set arreglo(y) = arreglo(x)
    Set arreglo(x) = aux
  End If
 Next y
Next x
End Sub

So far I've researched the Selection Sort but I know you can't delete items from an array so I can't make two lists to sort the values from one to the other. I could put my data in collection but I have had trouble regarding the quality of the data unless I alocate the memory beforehand (like in an array).

https://stackoverflow.com/a/5104206/6646710 this quicksort has worked very well for me in the past — PalimPalim, Aug 22 '17 at 19:09

score 4 · Accepted Answer · answered Aug 22 '17 at 19:26

There's a couple of things you can do to improve the execution time:

Load all the properties in an array
Sort some pointers instead of the objects
Use a better algorithm like QucikSort

With you example:

Sub Sort(arreglo As Variant)
  Dim cache, vals(), ptrs() As Long, i As Long

  ReDim vals(LBound(arreglo) To UBound(arreglo))
  ReDim ptrs(LBound(arreglo) To UBound(arreglo))

  ' load the properties and fill the pointers
  For i = LBound(arreglo) To UBound(arreglo)
    vals(i) = UCase(arreglo(i).id_flujo)
    ptrs(i) = i
  Next

  ' sort the pointers
  QuickSort vals, ptrs, 0, UBound(vals)

  ' make a copy
  cache = arreglo

  ' set the value for each pointer
  For i = LBound(arreglo) To UBound(arreglo)
    Set arreglo(i) = cache(ptrs(i))
  Next
End Sub


Private Sub QuickSort(vals(), ptrs() As Long, ByVal i1 As Long, ByVal i2 As Long)
  Dim lo As Long, hi As Long, p As Long, tmp As Long
  lo = i1
  hi = i2
  p = ptrs((i1 + i2) \ 2)

  Do
    While vals(ptrs(lo)) < vals(p): lo = lo + 1: Wend
    While vals(ptrs(hi)) > vals(p): hi = hi - 1: Wend

    If lo <= hi Then
      tmp = ptrs(hi)
      ptrs(hi) = ptrs(lo)
      ptrs(lo) = tmp
      lo = lo + 1
      hi = hi - 1
    End If
  Loop While lo <= hi

  If i1 < hi Then QuickSort vals, ptrs, i1, hi
  If lo < i2 Then QuickSort vals, ptrs, lo, i2
End Sub

If end users will see the results, I'd suggest comparing values using a [Natural Number Comparison](https://stackoverflow.com/a/19415281/1445339) — Profex, Aug 22 '17 at 20:10
This takes arround 10 seconds for 180.000 values so I'd say it solves the issue, thank you very much — eduardo0, Aug 22 '17 at 20:52

Sort array in VBA

1 Answers1