Dies ist eine alte Version des Dokuments!

Sortieren von Texten

Die zum alphanumerischen Sortieren wohl bekannteste Routine dürfte "QuickSort" sein, eine rekursive und daher sehr schnelle Anwendung. Man muss nur die zu sortierenden Texte in ein eindimensionales Array übertragen und dann "QuickSort" mit dem Array und Unter- und Obergrenze des Arrays aufrufen. Soll das ganze Array sortiert werden, was der Normalfall sein dürfte, reicht es für Ober- und Untergrenze jeweils "" einzutragen. Nach dem Durchlauf stehen die Texte in sortierter Reihenfolge im Array zur Verfügung.

Mit dem folgenden Skriptbeispiel wird ein Dialog aufgerufen, der die Eingabe beliebiger Texte erlaubt, bzw. wo man über einen Button einen Beispieltext aufrufen kann. Nach Mausklick auf "Sortieren" werden diese Texte im Ergebnisfenster sortiert angezeigt.

Sortieren (vbs)

'FFSubmenu=Test 'FFName=Sortieren

'Demo Sortieren von Texten Option Explicit

Dim ListenArray,Ergebnis,Abbruch '———————————————————————— call main '———————————————————————— Sub main

'** Start Dialog Demo Sortieren ** FF_AddDialog "Demo Sortieren",145,98 FF_AddControl "Demo Sortieren","Eingabe","STATIC",5,1,65,10 FF_SetControlStyle "Demo Sortieren","Eingabe",1 FF_AddControl "Demo Sortieren","UrListe","EDIT",5,12,65,65 FF_AddControl "Demo Sortieren","Ergebnis","STATIC",75,1,65,10 FF_SetControlStyle "Demo Sortieren","Ergebnis",1 FF_AddControl "Demo Sortieren","SortListe","EDIT",75,12,65,65 FF_SetControlStyle "Demo Sortieren","SortListe",2048 FF_AddControl "Demo Sortieren","Beipieltext laden","BUTTON",14,84,48,9 FF_AddControl "Demo Sortieren","Sortieren","BUTTON",92,82,33,11 '** End Dialog Demo Sortieren **

do

 Abbruch = false
 Select Case FF_ShowDialog ("Demo Sortieren")
 Case "CANCEL"
    exit do
 Case "Beipieltext laden"
    FF_SetControl "Demo Sortieren","UrListe", "" & _
       "Ölgemälde" & vbCrLf & "gemeinsam" & vbCrLf & "Äxte" & vbCrLf & "Wehmut" & vbCrLf & "danken" & vbCrLf & _
       "Birnbaum" & vbCrLf & "Übelkeit" & vbCrLf & "zerreißen" & vbCrLf & "tanken" & vbCrLf & "Geruch"
 Case "Sortieren"
    call Vorbereitung
    if not Abbruch then
       call QuickSort(ListenArray,"","")
       Ergebnis = join(ListenArray,vbNewLine)
       FF_SetControl "Demo Sortieren","SortListe",Ergebnis
    end if
 End Select

loop

FF_CloseDialog ("Demo Sortieren")

End Sub '———————————————————————— Sub Vorbereitung Dim Text

Text = FF_GetControl ("Demo Sortieren","UrListe") if len(Text) = 0 then

 msgbox "Es wurde kein Text eingegeben!",vbInformation,"Hinweis"
 Abbruch = true
 exit sub

end if

ListenArray = split(Text,vbNewLine)

End Sub '———————————————————————— Sub QuickSort(vSort,ByVal lngStart,ByVal lngEnd) '### Sortieren des Arrays 'vSort' nach ASCII-Werten

Dim i,j,h,x

if lngStart = "" then lngStart = 0 if lngEnd = "" then lngEnd = ubound(vSort)

i = lngStart : j = lngEnd x = vSort¹⁾

¹⁾

lngStart + lngEnd) / 2) '# Array aufteilen Do

 While (vSort(i) < x): i = i + 1: Wend
 While (vSort(j) > x): j = j - 1: Wend

 If (i <= j) Then
    '# Wertepaare miteinander tauschen
    h = vSort(i)
    vSort(i) = vSort(j)
    vSort(j) = h
    i = i + 1: j = j - 1
 End If

Loop Until (i > j) '# Rekursion If (lngStart < j) Then call QuickSort(vSort,lngStart,j) If (i < lngEnd) Then call QuickSort(vSort,i,lngEnd) End Sub '————————————————————————

Wie man am Sortierergebnis des Beispieltextes sehen kann, erfolgt die Sortierung nach ASCII-Werten. Das hat zur Folge, dass erst nach Großbuchstaben, dann nach Kleinbuchstaben und zum Schluss nach Umlauten sortiert wird.

Wünschenswert ist natürlich, dass unabhängig von Groß- und Kleinschreibung sortiert wird und die Umlaute Ä, Ö, Ü bzw. ä, ö, ü wie Ae, Oe, Ue bzw. ae, oe, ue behandelt werden. Um letzteres zu erreichen, zumindest jeweils für den Anfangsbuchstaben eines Textes, kann man als Vorbereitung zum Sortieren die Umlaute bei den Anfangsbuchstaben entsprechend ersetzen und den Originalumlaut zur späteren Rekonstruktion mit einem Trennzeichen dem Text anhängen. Anschließend werden noch alle Texte in Großbuchstaben gewandelt.
Nach dem Sortieren werden in der Rekonstruktionsroutine die Texte mit Trennzeichen gesucht und die Umlaute wieder hergestellt. Dann wird für jeden Text der Ursprungstext gesucht und dieser mit der ursprünglichen Groß- und Kleinschreibung wieder eingesetzt.

==== Sortieren+ (vbs) ==== 'FFSubmenu=Test 'FFName=Sortieren+ 'Demo Sortieren von Texten Option Explicit Dim UrListenArray,ListenArray,Ergebnis,Abbruch const TZ = "|" 'Trennzeichen zur Kennzeichnung von Umlauten '———————————————————————— call main '———————————————————————— Sub main '** Start Dialog Demo Sortieren ** FF_AddDialog "Demo Sortieren",145,98 FF_AddControl "Demo Sortieren","Eingabe","STATIC",5,1,65,10 FF_SetControlStyle "Demo Sortieren","Eingabe",1 FF_AddControl "Demo Sortieren","UrListe","EDIT",5,12,65,65 FF_AddControl "Demo Sortieren","Ergebnis","STATIC",75,1,65,10 FF_SetControlStyle "Demo Sortieren","Ergebnis",1 FF_AddControl "Demo Sortieren","SortListe","EDIT",75,12,65,65 FF_SetControlStyle "Demo Sortieren","SortListe",2048 FF_AddControl "Demo Sortieren","Beipieltext laden","BUTTON",17,83,44,9 FF_AddControl "Demo Sortieren","Sortieren","BUTTON",102,82,33,11 '** End Dialog Demo Sortieren ** do

 Abbruch = false
 Select Case FF_ShowDialog ("Demo Sortieren")
 Case "CANCEL"
    exit do
 Case "Beipieltext laden"
    FF_SetControl "Demo Sortieren","UrListe", "" & _
       "Ölgemälde" & vbCrLf & "gemeinsam" & vbCrLf & "Äxte" & vbCrLf & "Wehmut" & vbCrLf & "danken" & vbCrLf & _
       "Birnbaum" & vbCrLf & "Übelkeit" & vbCrLf & "zerreißen" & vbCrLf & "tanken" & vbCrLf & "Geruch"
 Case "Sortieren"
    call Vorbereitung
    if not Abbruch then
       call QuickSort(ListenArray,"","")
       call Rekonstruktion
       Ergebnis = join(ListenArray,vbNewLine)
       FF_SetControl "Demo Sortieren","SortListe",Ergebnis
    end if
 End Select

loop FF_CloseDialog ("Demo Sortieren") End Sub '———————————————————————— Sub Vorbereitung Dim Text,n,UL,ULn Text = FF_GetControl ("Demo Sortieren","UrListe") if len(Text) = 0 then

 msgbox "Es wurde kein Text eingegeben!",vbInformation,"Hinweis"
 Abbruch = true
 exit sub

end if UrListenArray = split(Text,vbNewLine) 'Sicherung des Ursprungs ListenArray = split(Text,vbNewLine) '### Umlautkorrektur für das erste Zeichen for n = 0 to UBound(ListenArray)

 UL = left(ListenArray(n),1)
 if instr("ÖÄÜöäü",UL) > 0 then
    select case UL
       case "Ä","ä" : ULn = "Ae"
       case "Ö","ö" : ULn = "Oe"
       case "Ü","ü" : ULn = "Ue"
    case else
    end select
    ListenArray(n) = ULn & mid(ListenArray(n),2) & TZ & UL
 end if

 '### String in Großbuchstaben umwandeln
 ListenArray(n) = ucase(ListenArray(n))

next End Sub '———————————————————————— Sub Rekonstruktion Dim n,pos,element '### Umlaute wieder zurück setzen for n = 0 to UBound(ListenArray)

 pos = instr(ListenArray(n),TZ)
 if pos > 0 then
    ListenArray(n) = right(ListenArray(n),1) & mid(ListenArray(n),3,pos-3)
 end if

 '### ursprüngliche Groß- und Kleinschreibung wieder herstellen
 for each element in UrListenArray
    if ListenArray(n) = ucase(element) then ListenArray(n) = element :   exit for
 next

next End Sub '———————————————————————— Sub QuickSort(vSort,ByVal lngStart,ByVal lngEnd) '### Sortieren des Arrays 'vSort' nach ASCII-Werten Dim i,j,h,x if lngStart = "" then lngStart = 0 if lngEnd = "" then lngEnd = ubound(vSort) i = lngStart : j = lngEnd x = vSort((lngStart + lngEnd) / 2) '# Array aufteilen Do

 While (vSort(i) < x): i = i + 1: Wend
 While (vSort(j) > x): j = j - 1: Wend

 If (i <= j) Then
    '# Wertepaare miteinander tauschen
    h = vSort(i)
    vSort(i) = vSort(j)
    vSort(j) = h
    i = i + 1: j = j - 1
 End If

Loop Until (i > j) '# Rekursion If (lngStart < j) Then call QuickSort(vSort,lngStart,j) If (i < lngEnd) Then call QuickSort(vSort,i,lngEnd) End Sub '————————————————————————
Auch Zahlen werden richtig sortiert, wie man ausprobieren kann. Allerdings werden die Zahlen wie Text behandelt. 1,35,2,17 ergibt sortiert 1,17,2,35, wo hingegen bei 01, 35, 02, 17 die gewünschte Reihenfolge 01, 02, 17, 35 angezeigt wird. Bei Zahlen muss also auf immer gleiche Stellenzahl geachtet und vorlaufende Stellen entsprechen mit Nullen aufgefüllt werden.

====== Mehrdimensionales Feld sortieren ====== Sub QuickSortMultiDim(vSort, index, lngStart, lngEnd)

  ' sortiert ein zweidimensionales Feld nach einem anzugebenden Index (Spalte)
  ' vSort -> zweidimensionales Array
  ' index -> Spalte, nach der sortiert werden soll (1, 2, 3, ...)
   Dim i, j, h, x, u, lb_dim, ub_dim
  ' Wird die Bereichsgrenze mit "" angegeben, wird das gesamte Array sortiert
  if lngStart = "" then lngStart = 0
  if lngEnd = "" then lngEnd = ubound(vSort)
  ' Wird Index mit "" angegeben, wird nach der ersten Spalte sortiert
  if index = "" then index = 1

  ' Anzahl Elemente pro Datenzeile
  lb_dim = LBound(vSort, 2)
  ub_dim = UBound(vSort, 2)

  i = lngStart
  j = lngEnd
  x = vSort((lngStart + lngEnd) / 2, index - 1)

  ' Array aufteilen
  Do
      While (vSort(i, index - 1) < x): i = i + 1: Wend
      While (vSort(j, index - 1) > x): j = j - 1: Wend

      If (i <= j) Then
          ' Wertepaare miteinander tauschen
          For u = lb_dim To ub_dim
              h = vSort(i, u)
              vSort(i, u) = vSort(j, u)
              vSort(j, u) = h
          Next
          i = i + 1: j = j - 1
      End If
  Loop Until (i > j)

' Rekursion (Funktion ruft sich selbst auf)
If (lngStart < j) Then QuickSortMultiDim vSort, index, lngStart, j
If (i < lngEnd) Then QuickSortMultiDim vSort, index, i, lngEnd

End Sub

Sortieren+ (vbs)