Autor: Max Kaffl (Nepumuk)  --- Aus Excel VBA - Gruppe: Verschiedenes

Quicksort Spezial - Sortierkriterien und mehrere Spalten

Autor: Max Kaffl (Nepumuk) - Erstellt: --      - Letzte Revision: --
Quicksort mit mehreren Sortierkriterien

Beim Quicksort war bisher das Sortieren mit nur einem Kriterium möglich. Diese Variante bietet die Möglichkeit nach nach belibig vielen Kriterien zu sortieren. Dabei kann für jedes Kriterium unabhängig eine aufsteigende oder absteigende Sortierfolge gewählt werden.

Der Routine werden folgende Parameter übergeben:

·
vntSortArray = Der Sortierschlüssel
·
vntArray = Das zu sortierende Array

Der Sortierschlüssel ist ein Array mit minimal einem Eintrag. Der erste Eintrag gibt die Spalte mit dem obersten Sortierkriterium an. Der zweite Eintrag das zweite Sortierkriterium usw. Ist dies Zahl positiv, wird aufsteigend sortiert, ist sie negativ, dann wird absteigend sortiert.

Wollen Sie ihr Array nach der 1., 3. und 5. Spalte sortieren, so steht im Array „vntSortArray" als erster Eintrag eine 1, als zweiter eine 3 und als dritter eine 5. Sie wollen die Spalte 1 und 3 aufsteigend und die Spalte 5 absteigend sortieren, dann steht im Array „vntSortArray" als erster Eintrag eine 1, als zweiter eine 3 und als dritter eine -5.

In der Beispielroutine „prcTest" wird ein Array mit 30 Spalten und 10.000 Zeilen erst mit Zufallszahlen von 1 bis 5 gefüllt und anschließend nach 6 Spalten sortiert.

1. Nach Spalte 1 aufsteigend.
2. Nach Spalte 2 absteigend.
3. Nach Spalte 8 aufsteigend.
4. Nach Spalte 3 aufsteigend.
5. Nach Spalte 4 absteigend.
6. Nach Spalte 5 absteigend.

Dieser Code befindet sich in einem Standardmodul.



' **************************************************************
' Modul: Modul1 Typ = Allgemeines Modul
' **************************************************************

Option Explicit

' Code Max Kaffl 2005

Public Sub prcTest()
 Dim intColumn As Integer
 Dim lngRow As Long
 Dim vntArray(1 To 10000, 1 To 30) As Variant
 Dim vntSortArray As Variant

 'die zu sortierenden Spalten
 'negative Zahl = Spalte absteigend sortieren
 'positive Zahl = Spalte aufsteigend sortieren
 vntSortArray = Array(1, -2, 8, 3, -4, -5)

 'TestArray füllen
 Randomize Timer
 For lngRow = 1 To 10000
  For intColumn = 1 To 30
   vntArray(lngRow, intColumn) = Fix((5 * Rnd) + 1)
  Next
 Next
 
 'Sortierroutine starten
 
 Call prcSort(vntSortArray, vntArray())

 'Ausgabe Testarray
 Application.ScreenUpdating = False
 Range("A1:AD10000").Value = vntArray
 Application.ScreenUpdating = True

End Sub

Private Sub prcSort(vntSortArray As Variant, vntArray() As Variant)
 Dim intIndex As Integer
 Dim lngIndex1 As Long, lngIndex2 As Long, lngRowsArray() As Long
 Dim lngRowsCount As Long, lngRangeCount As Long
 Dim vntTemp As Variant
 ReDim lngRowsArray(0 To 1, 0 To UBound(vntArray) * 2)
 
 'Array für den 1. Sortierlauf
 lngRowsArray(0, 0) = LBound(vntArray)
 lngRowsArray(0, 1) = UBound(vntArray)
 lngRowsCount = 1

 For intIndex = LBound(vntSortArray) To UBound(vntSortArray)

  'Wenn eine Spalte angegeben
  If vntSortArray(intIndex) <> 0 Then
   lngRangeCount = -1

   'Schleife zum sortieren der einzelnen Bereiche
   For lngIndex1 = 0 To lngRowsCount Step 2

    'Sortieren des Bereichs, wenn Zeilenzahl größer 1
    If lngRowsArray(0, lngIndex1) <> lngRowsArray(0, lngIndex1 + 1) Then

     Call prcQuickSort(CLng(lngRowsArray(0, lngIndex1)), _
      CLng(lngRowsArray(0, lngIndex1 + 1)), CInt(Abs(vntSortArray(intIndex))), _
      CBool(vntSortArray(intIndex) > 0), vntArray())

     'sortierten Bereich merken
     lngRangeCount = lngRangeCount + 2
     lngRowsArray(1, lngRangeCount - 1) = lngRowsArray(0, lngIndex1)
     lngRowsArray(1, lngRangeCount) = lngRowsArray(0, lngIndex1 + 1)

    End If
   Next
    
   lngRowsCount = -1

   'Durchsuchen der soeben sortierten Spalte nach Wertewechsel
   For lngIndex1 = 0 To lngRangeCount Step 2

    '1. Zeile des zu sortierenden Bereichs
    vntTemp = vntArray(lngRowsArray(1, lngIndex1), Abs(vntSortArray(intIndex)))
    lngRowsCount = lngRowsCount + 1
    lngRowsArray(0, lngRowsCount) = lngRowsArray(1, lngIndex1)

    'Suche nach Wechsel innerhalb des Bereichs
    For lngIndex2 = lngRowsArray(1, lngIndex1) To lngRowsArray(1, lngIndex1 + 1)
     If vntTemp <> vntArray(lngIndex2, Abs(vntSortArray(intIndex))) Then
      lngRowsCount = lngRowsCount + 2
      lngRowsArray(0, lngRowsCount - 1) = lngIndex2 - 1
      lngRowsArray(0, lngRowsCount) = lngIndex2
      vntTemp = vntArray(lngIndex2, Abs(vntSortArray(intIndex)))
     End If
    Next

    'letzte Zeile des zu sortierenden Bereichs
    lngRowsCount = lngRowsCount + 1
    lngRowsArray(0, lngRowsCount) = lngRowsArray(1, lngIndex1 + 1)

   Next
  End If
 Next
End Sub

Private Sub prcQuickSort(lngLbound As Long, lngUbound As Long, _
 intSortColumn As Integer, bntSortKey As Boolean, vntArray() As Variant)
 Dim intIndex As Integer
 Dim lngIndex1 As Long, lngIndex2 As Long
 Dim vntTemp As Variant, vntBuffer As Variant
 lngIndex1 = lngLbound
 lngIndex2 = lngUbound
 vntBuffer = vntArray((lngLbound + lngUbound) \ 2, intSortColumn)
 Do
  If bntSortKey Then
   Do While vntArray(lngIndex1, intSortColumn) < vntBuffer
    lngIndex1 = lngIndex1 + 1
   Loop
   Do While vntBuffer < vntArray(lngIndex2, intSortColumn)
    lngIndex2 = lngIndex2 - 1
   Loop
  Else
   Do While vntArray(lngIndex1, intSortColumn) > vntBuffer
    lngIndex1 = lngIndex1 + 1
   Loop
   Do While vntBuffer > vntArray(lngIndex2, intSortColumn)
    lngIndex2 = lngIndex2 - 1
   Loop
  End If
  If lngIndex1 < lngIndex2 Then
   If vntArray(lngIndex1, intSortColumn) <> _
    vntArray(lngIndex2, intSortColumn) Then
    For intIndex = LBound(vntArray, 2) To UBound(vntArray, 2)
     vntTemp = vntArray(lngIndex1, intIndex)
     vntArray(lngIndex1, intIndex) = _
      vntArray(lngIndex2, intIndex)
     vntArray(lngIndex2, intIndex) = vntTemp
    Next
   End If
   lngIndex1 = lngIndex1 + 1
   lngIndex2 = lngIndex2 - 1
  ElseIf lngIndex1 = lngIndex2 Then
   lngIndex1 = lngIndex1 + 1
   lngIndex2 = lngIndex2 - 1
  End If
 Loop Until lngIndex1 > lngIndex2
 If lngLbound < lngIndex2 Then Call prcQuickSort(lngLbound, _
  lngIndex2, intSortColumn, bntSortKey, vntArray())
 If lngIndex1 < lngUbound Then Call prcQuickSort(lngIndex1, _
  lngUbound, intSortColumn, bntSortKey, vntArray())
End Sub


Weitere Artikel der Gruppe: Verschiedenes Aus Excel VBA
Nach oben