Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0547: Sortieren mehrdimensionaler Arrays mit Quicksort

VB 5/6-Tipp 0547: Sortieren mehrdimensionaler Arrays mit Quicksort

 von Norbert Pfeiffer

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [3,29 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------ Anfang Projektdatei quicksort.vbp  ------------
'------- Anfang Formular "sorter" alias quicksort.frm -------
' Steuerelement: Schaltfläche "cmd_end"
' Steuerelement: Schaltfläche "cmd_date"
' Steuerelement: Schaltfläche "cmd_shff"
' Steuerelement: Listen-Steuerelement "List2"
' Steuerelement: Schaltfläche "cmd_char"
' Steuerelement: Listen-Steuerelement "List1"
Option Explicit



Dim Feld(0 To 555, 0 To 1)

Private Sub quicksort(ByVal LB As Long, ByVal UB As Long, D As Integer)
Dim A           As Integer
Dim X           As Long
Dim P1          As Long
Dim P2          As Long
Dim Ref(0 To 1) As Variant
Dim TMP(0 To 1) As Variant
A = 0
If D = 0 Then: A = 1
P1 = LB
P2 = UB
X = (P1 + P2) / 2
Ref(D) = Feld(X, D)
Ref(A) = Feld(X, A)
  Do
    Do While (Feld(P1, D) < Ref(D))
    P1 = P1 + 1
    Loop
    Do While (Feld(P2, D) > Ref(D))
    P2 = P2 - 1
    Loop
    If P1 <= P2 Then
    TMP(D) = Feld(P1, D)
    TMP(A) = Feld(P1, A)
    Feld(P1, D) = Feld(P2, D)
    Feld(P1, A) = Feld(P2, A)
    Feld(P2, D) = TMP(D)
    Feld(P2, A) = TMP(A)
    P1 = P1 + 1
    P2 = P2 - 1
    End If
  Loop Until (P1 > P2)
If LB < P2 Then Call quicksort(LB, P2, D)
If P1 < UB Then Call quicksort(P1, UB, D)
End Sub

Private Sub Form_Load()
Call Shuffle
End Sub

Private Sub cmd_shff_Click()
Call Shuffle
End Sub

Private Sub cmd_char_Click()
Dim X   As Integer
List2.Clear
Call quicksort(LBound(Feld), UBound(Feld), 0)
  For X = 0 To UBound(Feld)
  List2.AddItem Feld(X, 0) & ",  " & Feld(X, 1)
  Next X
End Sub

Private Sub cmd_date_Click()
Dim X   As Integer
List2.Clear
Call quicksort(LBound(Feld), UBound(Feld), 1)
  For X = 0 To UBound(Feld)
  List2.AddItem Feld(X, 1) & ",  " & Feld(X, 0)
  Next X
End Sub

Private Sub cmd_end_Click()
End
End Sub

Private Sub Shuffle()
Dim X   As Integer
Dim Y   As Integer
Dim aa  As String
Dim bb  As Date
Call Randomize(Timer)
List1.Clear
List2.Clear
  For X = 0 To UBound(Feld)
  aa = ""
    For Y = 0 To 7
    aa = aa & Chr$(Rnd * 25 + 97)
    Next Y
  bb = CDate(Int(Rnd * 27 + 1) & "." & _
             Int(Rnd * 11 + 1) & "." & _
             Int(Rnd * 33 + 1969) & " " & _
             Int(Rnd * 24) & ":" & _
             Int(Rnd * 58 + 1) & ":" & _
             Int(Rnd * 58 + 1))
  List1.AddItem aa & ",  " & bb
  Feld(X, 0) = aa
  Feld(X, 1) = bb
  Next X
End Sub
'-------- Ende Formular "sorter" alias quicksort.frm --------
'------------- Ende Projektdatei quicksort.vbp  -------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 6 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.