' **************************************************************
' 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