Quicksort

Der Quicksortalgorithmus ist sehr schnell. Aber die Arbeitsweise ist nicht leicht zu durchschauen. Ich habe lange gebraucht, bis sich bei mir der Schleier gelüftet hat. Erklären kann ich ihn aber nicht, am besten ist, man beobachtet ihn bei der Arbeit. Eine User-Form mit
vier Command Button
1. cmbMischen
2. cmbEinzelschritt
3. cmbSortieren
4. cmbBeenden
und einer Listbox mit Namen lsbEinträge ist dafür erforderlich.

Quicksort.zip  27 kB

Private AufrufNummerGesamt As Long
Private Schritt As Long
Private Einzelschritt As Boolean
Private Abbrechen As Boolean
'Vier Command Button
'1. cmbMischen
'2. cmbEinzelschritt
'3. cmbSortieren
'4. cmbBeenden
'Eine Listbox mit Namen lsbEinträge

Private Sub cmbBeenden_Click()
    Me.Hide
End Sub

Private Sub cmbMischen_Click()
    Mischen
End Sub

Private Sub UserForm_Activate()
    Mischen
    Me.Left = Me.Left \ 2
End Sub

Private Sub cmbEinzelschritt_Click()
    Einzelschritt = True
    Abbrechen = False
    Schritt = 0
    AufrufNummerGesamt = 0
    QuickSortieren 0, lsbEinträge.ListCount - 1
    AllesSelectierteLöschen
End Sub

Private Sub cmbSortieren_Click()
    Einzelschritt = False
    Abbrechen = False
    Schritt = 0
    AufrufNummerGesamt = 0
    QuickSortieren 0, lsbEinträge.ListCount - 1
End Sub

Private Sub QuickSortieren(ByVal Unten&, ByVal Oben&)
Dim ZeigerUnten&, ZeigerOben&, Vergleichswert$, Ref$, dummy$
Dim MyMessage As String, AufrufNummer As Long
Dim Vergleichsindex As Long
With lsbEinträge
    If Einzelschritt And Not (Abbrechen) Then
        AufrufNummerGesamt = AufrufNummerGesamt + 1
        AufrufNummer = AufrufNummerGesamt
        Schritt = Schritt + 1
        MyMessage = ""
        MyMessage = MyMessage & "Aufrufnummer : " & AufrufNummer & vbCrLf
        MyMessage = MyMessage & "Schrittnummer : " & Schritt & vbCrLf
        MyMessage = MyMessage & "Übergabeparameter unten : " & Unten + 1 & vbCrLf
        MyMessage = MyMessage & "Übergabeparameter  oben : " & Oben + 1 & vbCrLf
        MyMessage = MyMessage & "Routine Quicksortieren wurde neu aufgerufen!"
        AllesSelectierteLöschen
        .Selected(Unten) = True
        .Selected(Oben) = True
        IIf MsgBox(MyMessage, vbOKCancel, "Mit Einzelschritt weitermachen?") = vbCancel Then _
                   Abbrechen = True
    End If
    ZeigerUnten = Unten
    ZeigerOben = Oben
    Vergleichsindex = (ZeigerUnten + ZeigerOben) / 2
    Vergleichswert = .List(Vergleichsindex)
    Do
      Do While Vergleich(.List(ZeigerUnten), Vergleichswert, "<")
        If Einzelschritt And Not (Abbrechen) Then
            Schritt = Schritt + 1
            MyMessage = ""
            MyMessage = MyMessage & "Aufrufnummer : " & AufrufNummer & vbCrLf
            MyMessage = MyMessage & "Schrittnummer : " & Schritt & vbCrLf
            MyMessage = MyMessage & "Pos. Liste unten : " & ZeigerUnten + 1 & vbCrLf
            MyMessage = MyMessage & "Pos. Liste oben : " & ZeigerOben + 1 & vbCrLf
            MyMessage = MyMessage & "Vergleichswert : " & Vergleichswert & vbCrLf
            MyMessage = MyMessage & "Eintrag unten : " & .List(ZeigerUnten) & vbCrLf
            MyMessage = MyMessage & _
                  "Vergleich ob der 'Eintrag unten' kleiner ist als der Vergleichswert: ist Wahr!" & vbCrLf
            MyMessage = MyMessage & _
                 "Weitermachen bis der 'Eintrag unten' kleiner ist als der Vergleichswert: ist Falsch!"
            AllesSelectierteLöschen
            .Selected(Vergleichsindex) = True
            .Selected(ZeigerUnten) = True
            .Selected(ZeigerOben) = True
            If MsgBox(MyMessage, vbOKCancel, "Mit Einzelschritt weitermachen?") = vbCancel Then _
                   Abbrechen = True
        End If
        ZeigerUnten = ZeigerUnten + 1
      Loop
      Do While Vergleich(.List(ZeigerOben), Vergleichswert, ">")
        If Einzelschritt And Not (Abbrechen) Then
            Schritt = Schritt + 1
            MyMessage = ""
            MyMessage = MyMessage & "Aufrufnummer : " & AufrufNummer & vbCrLf
            MyMessage = MyMessage & "Schrittnummer : " & Schritt & vbCrLf
            MyMessage = MyMessage & "Pos. Liste unten : " & ZeigerUnten + 1 & vbCrLf
            MyMessage = MyMessage & "Pos. Liste oben : " & ZeigerOben + 1 & vbCrLf
            MyMessage = MyMessage & "Vergleichswert : " & Vergleichswert & vbCrLf
            MyMessage = MyMessage & "Eintrag oben : " & .List(ZeigerOben) & vbCrLf
            MyMessage = MyMessage &  _
            "Vergleich ob der 'Eintrag oben' größer ist als der Vergleichswert: ist Wahr!" & vbCrLf
            MyMessage = MyMessage &  _
            "Weitermachen bis der 'Eintrag oben' größer ist als der Vergleichswert: ist Falsch!"
            AllesSelectierteLöschen
            .Selected(Vergleichsindex) = True
            .Selected(ZeigerUnten) = True
            .Selected(ZeigerOben) = True
           If MsgBox(MyMessage, vbOKCancel, "Mit Einzelschritt weitermachen?") = vbCancel Then _
                   Abbrechen = True
        End If
        ZeigerOben = ZeigerOben - 1
      Loop
      If ZeigerUnten <= ZeigerOben Then
        If Einzelschritt And Not (Abbrechen) Then
            Schritt = Schritt + 1
            MyMessage = ""
            MyMessage = MyMessage & "Aufrufnummer : " & AufrufNummer & vbCrLf
            MyMessage = MyMessage & "Schrittnummer : " & Schritt & vbCrLf
            MyMessage = MyMessage & "Pos. Liste unten : " & ZeigerUnten + 1 & vbCrLf
            MyMessage = MyMessage & "Pos. Liste oben : " & ZeigerOben + 1 & vbCrLf
            MyMessage = MyMessage & "Eintrag oben : " & .List(ZeigerOben) & vbCrLf
            MyMessage = MyMessage & "Eintrag unten : " & .List(ZeigerUnten) & vbCrLf
            MyMessage = MyMessage & "Index ZeigerUnten ist kleiner als der Index ZeigerOben" _
                   & vbCrLf
            MyMessage = MyMessage & "Einträge werden getauscht!"
            AllesSelectierteLöschen
            .Selected(Vergleichsindex) = True
            .Selected(ZeigerUnten) = True
            .Selected(ZeigerOben) = True
           If MsgBox(MyMessage, vbOKCancel, "Mit Einzelschritt weitermachen?") = vbCancel Then _
                   Abbrechen = True
        End If
        dummy = .List(ZeigerUnten)
        .List(ZeigerUnten) = .List(ZeigerOben)
        .List(ZeigerOben) = dummy
        ZeigerUnten = ZeigerUnten + 1
        ZeigerOben = ZeigerOben - 1
      End If
    Loop Until (ZeigerUnten > ZeigerOben)
    If Unten < ZeigerOben Then
        If Einzelschritt And Not (Abbrechen) Then
            Schritt = Schritt + 1
            MyMessage = ""
            MyMessage = MyMessage & "Aufrufnummer : " & AufrufNummer & vbCrLf
            MyMessage = MyMessage & "Schrittnummer : " & Schritt & vbCrLf
            MyMessage = MyMessage & "Anfangsindex unten : " & Unten + 1 & vbCrLf
            MyMessage = MyMessage & "Pos. Liste oben : " & ZeigerOben + 1 & vbCrLf
            MyMessage = MyMessage & "Der Anfangsindex unten ist kleiner als " & vbCrLf
            MyMessage = MyMessage & "der aktuelle Listindex oben " & vbCrLf
            MyMessage = MyMessage & "Der Routine QuickSortieren wird rekursiv aufgerufen "
            AllesSelectierteLöschen
            .Selected(Vergleichsindex) = True
            .Selected(Unten) = True
            .Selected(ZeigerOben) = True
            If MsgBox(MyMessage, vbOKCancel, "Mit Einzelschritt weitermachen?") = vbCancel Then _
                   Abbrechen = True
        End If
        Call QuickSortieren(Unten, ZeigerOben)
    End If
    If ZeigerUnten < Oben Then
        If Einzelschritt And Not (Abbrechen) Then
            Schritt = Schritt + 1
            MyMessage = ""
            MyMessage = MyMessage & "Aufrufnummer : " & AufrufNummer & vbCrLf
            MyMessage = MyMessage & "Schrittnummer : " & Schritt & vbCrLf
            MyMessage = MyMessage & "Anfangsindex oben : " & Oben + 1 & vbCrLf
            MyMessage = MyMessage & "Pos. Listindex unten : " & ZeigerUnten + 1 & vbCrLf
            MyMessage = MyMessage & "Der Anfangsindex oben ist größer als " & vbCrLf
            MyMessage = MyMessage & "der aktuelle Listindex unten " & vbCrLf
            MyMessage = MyMessage & "Der Routine QuickSortieren wird rekursiv aufgerufen "
            AllesSelectierteLöschen
            .Selected(Vergleichsindex) = True
            .Selected(Oben) = True
            .Selected(ZeigerUnten) = True
            If MsgBox(MyMessage, vbOKCancel, "Mit Einzelschritt weitermachen?") = vbCancel Then _
                   Abbrechen = True
        End If
        Call QuickSortieren(ZeigerUnten, Oben)
    End If
End With
End Sub

Private Sub AllesSelectierteLöschen()
Dim i As Long
For i = 0 To lsbEinträge.ListCount - 1
    lsbEinträge.Selected(i) = False
Next
End Sub

Private Function Vergleich(ByVal Wert As String, ByVal Vergleichswert As String, _
       Operator As String) As Boolean
Select Case Operator
    Case ">"
        If StrComp(Wert, Vergleichswert, 1) = 1 Then Vergleich = True
    Case "<"
        If StrComp(Wert, Vergleichswert, 1) = -1 Then Vergleich = True
End Select
End Function

Private Sub Mischen()
Dim Zahlen(1 To 36) As String
Dim i As Long, k As Long
lsbEinträge.Clear
Randomize
For i = 48 To 57
    k = k + 1
    Zahlen(k) = i
Next
For i = 65 To 90
    k = k + 1
    Zahlen(k) = i
Next
k = 36
Do
    i = Int((k) * Rnd) + 1
    lsbEinträge.AddItem Chr(Zahlen(i))
    Zahlen(i) = Zahlen(k)
    k = k - 1
Loop While k > 0
End Sub