meta data for this page
  •  

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.gif

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)