Quicksort für zweidimensionale Datenfelder / Matrizen

Mit dieser Funktion kann in VBA ein mehrdimensionales Datenfelder oder eine Matrix nach einer bestimmten Spalte sortiert werden. Als Beispiel wird in einer Test-Funktion ein Datenfeld und ein Zellbereich mit der neuen Quicksort-Funktion sortiert. Die Option "aufsteigend/absteigend" (Parameter Descending) ist noch nicht verfügbar, lässt sich aber einfach hinzufügen.

Download der gesamten Excel-Datei

Und hier geht's zum Quellcode...

Option Explicit
Option Base 1

'---------------------------------------------------------------------------------------
' Module    : Quicksort_2D
' DateTime  : 16.04.2009
' Author    : Tobias - tobiasschmid.de - vba-blog.de
' Purpose   : Quicksort-Algorithmus für zweidimensionale Arrays
'---------------------------------------------------------------------------------------

Public Sub Test()
    Dim InputData(10, 2) As Variant
    Dim v As Variant, i As Long

    InputData(1, 1) = 5: InputData(2, 1) = 4: InputData(3, 1) = 9: InputData(4, 1) = 1: InputData(5, 1) = 8
    InputData(6, 1) = 7: InputData(7, 1) = 2: InputData(8, 1) = 6: InputData(9, 1) = 0: InputData(10, 1) = 3
    InputData(1, 2) = "a": InputData(2, 2) = "b": InputData(3, 2) = "c": InputData(4, 2) = "d": InputData(5, 2) = "e"
    InputData(6, 2) = "f": InputData(7, 2) = "g": InputData(8, 2) = "h": InputData(9, 2) = "i": InputData(10, 2) = "j"

    'Sortieren des Datenfelds InputData nach Spalte 1
    v = Quicksort(InputData, 1)
    For i = 1 To 10
        Debug.Print v(i, 1), v(i, 2), InputData(i, 1), InputData(i, 2)
    Next

    'Sortieren des Bereichs "D1:E11" nach Spalte 1 und Ausgabe der sortierten Matrix in Bereich "F1:G11"
    Range("F1:G11") = Quicksort(Range("D1:E11"), 1)
End Sub

Public Function Quicksort(InputData As Variant, SortColumn As LongOptional Descending As Boolean = TrueAs Variant
    Dim Data() As Variant
    Dim i As Long, j As Long, k As Long
    Dim i_Max As Long, j_Max As Long
    Dim temp As Variant

    'neues Datenfeld anlegen
    'if type
    If IsObject(InputData) Then
        'InputData ist vom Typ Range
        i_Max = InputData.Rows.Count
        j_Max = InputData.Columns.Count
    Else
        'InputData ist vom Typ Variant (double, string, ...)
        i_Max = UBound(InputData, 1)
        j_Max = UBound(InputData, 2)
    End If

    ReDim Data(i_Max, j_Max)

    'Daten in eigenes Datenfeld schreiben
    For i = 1 To i_Max
        For j = 1 To j_Max
            Data(i, j) = InputData(i, j)
        Next
    Next

    'Daten mischen
    For i = 1 To i_Max

        k = Rnd * (i_Max - 1) + 1
        For j = 1 To j_Max
            'Tausche Daten(i) mit Daten(j)
            temp = Data(i, j)
            Data(i, j) = Data(k, j)
            Data(k, j) = temp
        Next
    Next

    'Daten mit Quicksort sortieren
    Call Do_Quicksort(von:=1, bis:=i_Max, Data:=Data, SortColumn:=SortColumn, Columns:=j_Max)

    'Rückgabe
    Quicksort = Data
End Function

Private Sub Do_Quicksort(von As Long, bis As Long, Data As Variant, SortColumn As Long, Columns As Long)
    Dim Teiler As Long
    If bis > von Then
        Teiler = Teile(von:=von, bis:=bis, Data:=Data, SortColumn:=SortColumn, Columns:=Columns)
        Call Do_Quicksort(von:=von, bis:=Teiler - 1, Data:=Data, SortColumn:=SortColumn, Columns:=Columns)
        Call Do_Quicksort(von:=Teiler + 1, bis:=bis, Data:=Data, SortColumn:=SortColumn, Columns:=Columns)
    End If
End Sub

Private Function Teile(von As Long, bis As Long, Data As Variant, SortColumn As Long, Columns As Long)
    Dim temp As Variant
    Dim Index As Long
    Dim i As Long
    Index = von

    For i = von To bis - 1
        If Data(i, SortColumn) <= Data(bis, SortColumn) Then
            Call Tausche(Index, i, Data, Columns)
            Index = Index + 1
        End If
    Next
    Call Tausche(Index, bis, Data, Columns)
    Teile = Index
End Function

'------------------------------------------------------------------
' Procedure : Tausche
' DateTime  : 16.04.2009
' Author    : Tobias - tobiasschmid.de - vba-blog.de
' Purpose   : zwei Zeilen (i und j) der Matrix (Data) werden vertauscht
'------------------------------------------------------------------
Private Sub Tausche(i As Long, j As Long, Data As Variant, Columns As Long)
    Dim temp As Variant
    Dim k As Long

    'Tausche Daten(i,k) mit Daten(j,k) für alle k
    For k = 1 To Columns
        temp = Data(i, k)
        Data(i, k) = Data(j, k)
        Data(j, k) = temp
    Next
End Sub

Code eingefügt mit Syntaxhighlighter 4.15
AnhangGröße
Quicksort_für_zweidimensionale_Arrays.xls35 KB
Your rating: Keine Average: 4.3 (6 votes)