VBA-Quicksort Text mit Groß-/Kleinschreibung

[Andreas Killer]

Juhu. :-)

Ich steh irgendwie auf dem Schlauch und brauch mal 'nen Anstoß.

Ich möchte eine Sortroutine die mir Texte mit Beachtung der Groß-/
Kleinschreibung sortiert, wie die Lemmata im Lexikon.

a
A
ä
Ä
aa
aA
Aa
AA
aä
aÄ
Aä
AÄ
usw.

Eine etwas komplexere Liste kann man sich mit der Sub GenListe()
selber generieren.

Ich habe meinen QuickSort in sofern stabil das er ohne Beachtung der
Schreibweise ein stabiles Ergebnis liefert (Aufruf mit vbTextCompare)
und würde gerne beim Aufruf mit vbBinaryCompare das öbige Ergebnis
liefern.

Nicht wundern das er eine Kopie der Liste anlegt, diese sortiert und
das Original mitführt, mir ist nichts besseres eingefallen um ggf.
vorkommende Fehlerwerte =NV() aus Tabellen mit sortieren zu können.
Wer eine bessere Idee dazu hat... :-)

Und wie implementiert man eigentlich eine Sortierung nach einer
Vorgabeliste? Wenn ich also Mo,Di,Mi,Do,Fr,Sa,So sortierien möchte?

Andreas.

Option Explicit
Option Compare Binary

'Schwellwert um von QuickSort zu Insertion Sort zu wechseln
Private Const QTHRESH As Long = 9

Sub GenListe()
'Generiert eine Zeichenliste mit allen möglichen Kombinationen in
Spalte A
Dim Data, I As Long, J As Long, K As Long
Data = Array(Chr(65), Chr(66), Chr(97), Chr(98), Chr(228), Chr(196))
Columns(1).ClearContents
For I = LBound(Data) To UBound(Data)
K = K + 1
Cells(K, 1) = Data(I)
Next
For I = LBound(Data) To UBound(Data)
For J = LBound(Data) To UBound(Data)
K = K + 1
Cells(K, 1) = Data(I) & Data(J)
Next
Next
End Sub

Sub Mischen()
'Spalte A durchmischen
Dim I As Long, J As Long
Dim R As Range, Temp
Set R = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
For I = 1 To R.Rows.Count
J = Int((R.Rows.Count * Rnd) + 1)
Temp = R(I, 1)
R(I, 1) = R(J, 1)
R(J, 1) = Temp
Next
End Sub

Sub Sortieren()
'Spalte A sortieren
Dim R As Range, Temp
On Error GoTo ErrorHandler
Set R = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
Temp = WorksheetFunction.Transpose(R)
QuickSort Temp, , , vbBinaryCompare
'QuickSort Temp, , , vbTextCompare
'QuickSort Temp, , , vbDatabaseCompare
R = WorksheetFunction.Transpose(Temp)
Exit Sub

ErrorHandler:
MsgBox "Fehler " & Err.Number & ": " & Err.Description
End Sub

Function Dimension(Arr As Variant) As Long
'Returns number of dimensions of an array or 0 for an _
undimensioned array or -1 if no array at all.
If IsArray(Arr) Then
On Error GoTo Done
Do
Dimension = Dimension + 1
Loop While IsNumeric(UBound(Arr, Dimension))
End If
Done:
Dimension = Dimension - 1
End Function

Sub QuickSort(Liste, _
Optional ByVal Start, Optional ByVal Ende, _
Optional ByVal Compare As VbCompareMethod = _
vbDatabaseCompare, Optional ByVal SortOrder As XlSortOrder = _
xlAscending)
'Sortiert eine Liste mit beliebigen Werten im Bereich Start. _
.Ende
'vbDatabaseCompare sortiert Zahlen, ansonsten werden Texte _
sortiert

Dim I As Long, J As Long, C As Integer, Ci As Integer, Cj As _
Integer
Dim Pivot, Temp, Data
Dim DoResume As Boolean
Dim Stack(1 To 64) As Long
Dim StackPtr As Long

If Dimension(Liste) <> 1 Then _
Err.Raise 5, "QuickSort", "Liste muss 1 Dimension haben"

If IsMissing(Start) Then Start = LBound(Liste) Else If Start _
< LBound(Liste) Then Start = LBound(Liste)
If IsMissing(Ende) Then Ende = UBound(Liste) Else If Ende > _
UBound(Liste) Then Ende = UBound(Liste)
If SortOrder = xlAscending Then C = 1 Else C = -1

Ci = 1
Data = Liste
On Error GoTo ErrorHandler

Stack(StackPtr + 1) = Start
Stack(StackPtr + 2) = Ende
StackPtr = StackPtr + 2

Do
StackPtr = StackPtr - 2
Start = Stack(StackPtr + 1)
Ende = Stack(StackPtr + 2)

If Ende - Start < QTHRESH Then
'Insertionsort
Select Case Compare
Case vbDatabaseCompare
'Zahlen sortieren
If SortOrder = xlAscending Then
For J = Start + 1 To Ende
Pivot = Data(J)
Temp = Liste(J)
For I = J - 1 To Start Step -1
If Data(I) <= Pivot Then Exit For
Data(I + 1) = Data(I)
Liste(I + 1) = Liste(I)
Next
Data(I + 1) = Pivot
Liste(I + 1) = Temp
Next
Else
For J = Start + 1 To Ende
Pivot = Data(J)
Temp = Liste(J)
For I = J - 1 To Start Step -1
If Data(I) >= Pivot Then Exit For
Data(I + 1) = Data(I)
Liste(I + 1) = Liste(I)
Next
Data(I + 1) = Pivot
Liste(I + 1) = Temp
Next
End If
Case vbTextCompare
'Texte sortieren => MatchCase:=False
For J = Start + 1 To Ende
Pivot = Data(J)
Temp = Liste(J)
For I = J - 1 To Start Step -1
Ci = StrComp(Data(I), Pivot, Compare)
If Ci <> C Then Exit For
Data(I + 1) = Data(I)
Liste(I + 1) = Liste(I)
Next
Data(I + 1) = Pivot
Liste(I + 1) = Temp
Next
Case vbBinaryCompare
'Texte sortieren => MatchCase:=True
For J = Start + 1 To Ende
Pivot = Data(J)
Temp = Liste(J)
For I = J - 1 To Start Step -1
Ci = StrComp(Data(I), Pivot, vbTextCompare)
If Ci <> C Then Exit For
Data(I + 1) = Data(I)
Liste(I + 1) = Liste(I)
Next
Data(I + 1) = Pivot
Liste(I + 1) = Temp
Next
End Select
Else
'QuickSort
I = Start: J = Ende
Pivot = Data((Start + Ende) \ 2)
Do
Select Case Compare
Case vbDatabaseCompare
'Zahlen sortieren
If SortOrder = xlAscending Then
Do While (Data(I) < Pivot): I = I + 1: Loop
Do While (Data(J) > Pivot): J = J - 1: Loop
Else
Do While (Data(I) > Pivot): I = I + 1: Loop
Do While (Data(J) < Pivot): J = J - 1: Loop
End If

Case vbTextCompare
'Texte sortieren => MatchCase:=False
Ci = StrComp(Data(I), Pivot, Compare)
Do While (Ci = -C)
I = I + 1
Ci = StrComp(Data(I), Pivot, Compare)
Loop
Cj = StrComp(Data(J), Pivot, Compare)
Do While (Cj = C)
J = J - 1
Cj = StrComp(Data(J), Pivot, Compare)
Loop

Case vbBinaryCompare
'Texte sortieren => MatchCase:=True
Ci = StrComp(Data(I), Pivot, vbTextCompare)
Do While (Ci = -C)
I = I + 1
Ci = StrComp(Data(I), Pivot, vbTextCompare)
Loop
Cj = StrComp(Data(J), Pivot, vbTextCompare)
Do While (Cj = C)
J = J - 1
Cj = StrComp(Data(J), Pivot, vbTextCompare)
Loop
End Select

If I <= J Then
If I < J And Not (Ci = 0 And Cj = 0) Then
Temp = Liste(I)
Liste(I) = Liste(J)
Liste(J) = Temp
Temp = Data(I)
Data(I) = Data(J)
Data(J) = Temp
End If
I = I + 1: J = J - 1
End If
Loop Until I > J

If (Start < J) Then
'QuickSort Liste, Start, j, Compare, SortOrder
Stack(StackPtr + 1) = Start
Stack(StackPtr + 2) = J
StackPtr = StackPtr + 2
End If
If (I < Ende) Then
'QuickSort Liste, i, Ende, Compare, SortOrder
Stack(StackPtr + 1) = I
Stack(StackPtr + 2) = Ende
StackPtr = StackPtr + 2
End If
End If
Loop Until StackPtr = 0
Exit Sub

ErrorHandler:
If Err.Number = 13 Then
On Error GoTo RepeatError
DoResume = False
'Fehlerwerte können nicht vergleichen werden!
If IsError(Pivot) Then DoResume = True: Pivot = Chr(255) & _
CStr(Pivot)
If IsError(Data(I)) Then DoResume = True: Data(I) = Chr( _
255) & CStr(Data(I))
If IsError(Data(J)) Then DoResume = True: Data(J) = Chr( _
255) & CStr(Data(J))
If DoResume Then
Err.Clear
On Error GoTo ErrorHandler
Else
On Error GoTo 0
End If
Resume
Else
RepeatError:
On Error GoTo 0
Resume
End If
End Sub

[Peter Schleif]

Post by Andreas Killer
Ich möchte eine Sortroutine die mir Texte mit Beachtung der Groß-/
Kleinschreibung sortiert, wie die Lemmata im Lexikon.
a
A
[...] würde gerne beim Aufruf mit vbBinaryCompare das öbige Ergebnis
liefern.

Mit vbBinaryCompare allein kommst Du nicht ans Ziel, wie Du ja sicher
schon gemerkt hast. Denn der ASCII-Code - Unicode lasse ich jetzt mal
außen vor - von "a" (122) ist nun mal größer als der von "A" (65).

Du brauchst also eine Mapping-Tabelle, die Dir die korrekte Sortierung
vorgibt. Im einfachsten Fall ein Array 0..255 mit den ge'mappten
ASCII-Werten. Im folgendem Beispiel werden nur die ASCII-Code von A-Z
mit denen von a-z vertauscht und umgekehrt. Natürlich müsste man das
auch noch mit Umlauten und anderen Zeichen machen. Bei ASCII/ISO-8859
kein Problem. Lustig wird es erst bei Unicode. :-)

Post by Andreas Killer
Und wie implementiert man eigentlich eine Sortierung nach einer
Vorgabeliste? Wenn ich also Mo,Di,Mi,Do,Fr,Sa,So sortierien möchte?

Auch mit einer Mapping-Tabelle die die Sortierung vorgibt. Das kann z.B.
auch ein Dictionary sein oder eine Excel-Tabelle.

Peter


Sub Test()
Debug.Print MyStrComp("a", "A")
Debug.Print StrComp("a", "A", vbBinaryCompare)
End Sub

Function MyStrComp(ByVal s1 As String, ByVal s2 As String)
Dim map(0 To 255) As Integer
Dim i As Integer

For i = 0 To 255
Select Case i
Case 65 To 90: map(i) = i - 65 + 97
Case 97 To 122: map(i) = i - 97 + 65
Case Else: map(i) = i
End Select
Next

For i = 1 To Len(s1)
Mid(s1, i, 1) = Chr(map(Asc(Mid(s1, i, 1))))
Next
For i = 1 To Len(s2)
Mid(s2, i, 1) = Chr(map(Asc(Mid(s2, i, 1))))
Next

MyStrComp = StrComp(s1, s2, vbBinaryCompare)
End Function

[Peter Schleif]

Post by Peter Schleif

Post by Andreas Killer
Und wie implementiert man eigentlich eine Sortierung nach einer
Vorgabeliste? Wenn ich also Mo,Di,Mi,Do,Fr,Sa,So sortierien möchte?

Auch mit einer Mapping-Tabelle die die Sortierung vorgibt. Das kann z.B.
auch ein Dictionary sein oder eine Excel-Tabelle.

Sub Test2()
Debug.Print WeekdayComp("Mo", "Di")
End Sub

Function WeekdayComp(ByVal s1 As String, ByVal s2 As String)
Static map As Object
Dim value1 As Integer
Dim value2 As Integer

If map Is Nothing Then
Set map = CreateObject("Scripting.Dictionary")
map("mo") = 1
map("di") = 2
map("mi") = 3
map("do") = 4
map("fr") = 5
map("sa") = 6
map("so") = 7
End If

value1 = IIf(map.Exists(LCase(s1)), map(LCase(s1)), 99)
value2 = IIf(map.Exists(LCase(s2)), map(LCase(s2)), 99)

WeekdayComp = Sgn(value1 - value2)
End Function

[Andreas Killer]

Post by Peter Schleif
Mit vbBinaryCompare allein kommst Du nicht ans Ziel, wie Du ja sicher
schon gemerkt hast. Denn der ASCII-Code - Unicode lasse ich jetzt mal
außen vor - von "a" (122) ist nun mal größer als der von "A" (65).

Ja leider nicht ganz, ich habe noch ein wenig probiert und nun eine
Version die richtig sortiert, aber nur nach mehrfachem Sortieren...

Kann man im Code mit
#const Version = 1
aktivieren. Irgendwie hab ich da ein Brett vorm Kopp. :-))

Post by Peter Schleif
Du brauchst also eine Mapping-Tabelle, die Dir die korrekte Sortierung
vorgibt. Im einfachsten Fall ein Array 0..255 mit den ge'mappten

Das dachte ich mir schon, aber die Umsetzung scheint doch schwieriger
zu sein.

Post by Peter Schleif
Function MyStrComp(ByVal s1 As String, ByVal s2 As String)

Hmm, das scheint so nicht zu gehen oder ich mache nochwas falsch.

Ich hab das mal in meinen Code mit
#const Version = 2
eingebunden, das sortiert jedoch so:

a
aa
ab
aA
...
A
Aa
Ab
AA
...
Ä
Äa
Äb
ÄA
...
ä
äa
äb
äA

und nicht

a
A
ä
Ä
aa
aA
Aa

Magst Du da mal kucken wo ich den Fehler hab?

Andreas.

Option Explicit
Option Compare Binary

'Bei Version = 1 muss man Sortieren mehrfach aufrufen!????
#Const Version = 2

'Schwellwert um von QuickSort zu Insertion Sort zu wechseln
'Zum Testen kann man QTHRESH auch auf 0 setzen, dann läuft nur _
der Quicksort-Part.
Private Const QTHRESH As Long = 9

#If Version = 2 Then
Function MyStrComp(ByVal s1 As String, ByVal s2 As String)
Dim map(0 To 255) As Integer
Dim i As Integer

For i = 0 To 255
Select Case i
Case 65 To 90: map(i) = i - 65 + 97
Case 97 To 122: map(i) = i - 97 + 65
Case Else: map(i) = i
End Select
Next

For i = 1 To Len(s1)
Mid(s1, i, 1) = Chr(map(Asc(Mid(s1, i, 1))))
Next
For i = 1 To Len(s2)
Mid(s2, i, 1) = Chr(map(Asc(Mid(s2, i, 1))))
Next

MyStrComp = StrComp(s1, s2, vbBinaryCompare)
End Function
#End If

Sub GenListe()
'Generiert eine Zeichenliste mit allen möglichen _
Kombinationen in Spalte A
Dim Data, i As Long, J As Long, K As Long
Data = Array(Chr(65), Chr(66), Chr(97), Chr(98), Chr(228), _
Chr(196))
Columns(1).ClearContents
For i = LBound(Data) To UBound(Data)
K = K + 1
Cells(K, 1) = Data(i)
Next
For i = LBound(Data) To UBound(Data)
For J = LBound(Data) To UBound(Data)
K = K + 1
Cells(K, 1) = Data(i) & Data(J)
Next
Next
End Sub

Sub Mischen()
'Spalte A durchmischen
Dim i As Long, J As Long
Dim R As Range, Temp
Set R = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
For i = 1 To R.Rows.Count
J = Int((R.Rows.Count * Rnd) + 1)
Temp = R(i, 1)
R(i, 1) = R(J, 1)
R(J, 1) = Temp
Next
End Sub

Sub Sortieren()
'Spalte A sortieren
Dim R As Range, Temp
On Error GoTo ErrorHandler
Set R = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
Temp = WorksheetFunction.Transpose(R)
QuickSort Temp, , , vbBinaryCompare
'QuickSort Temp, , , vbTextCompare
'QuickSort Temp, , , vbDatabaseCompare
R = WorksheetFunction.Transpose(Temp)
Exit Sub

ErrorHandler:
MsgBox "Fehler " & Err.Number & ": " & Err.Description
End Sub

Function Dimension(Arr As Variant) As Long
'Returns number of dimensions of an array or 0 for an _
undimensioned array or -1 if no array at all.
If IsArray(Arr) Then
On Error GoTo Done
Do
Dimension = Dimension + 1
Loop While IsNumeric(UBound(Arr, Dimension))
End If
Done:
Dimension = Dimension - 1
End Function

Sub QuickSort(Liste, _
Optional ByVal Start, Optional ByVal Ende, _
Optional ByVal Compare As VbCompareMethod = _
vbDatabaseCompare, Optional ByVal SortOrder As XlSortOrder _
= xlAscending)
'Sortiert eine Liste mit beliebigen Werten im Bereich Start. _
.Ende
'vbDatabaseCompare sortiert Zahlen, ansonsten werden Texte _
sortiert

Dim i As Long, J As Long, C As Integer, Ci As Integer, Cj As _
Integer
Dim Pivot, Temp, Data
Dim DoResume As Boolean
Dim Stack(1 To 64) As Long
Dim StackPtr As Long

If Dimension(Liste) <> 1 Then _
Err.Raise 5, "QuickSort", "Liste muss 1 Dimension haben"

If IsMissing(Start) Then Start = LBound(Liste) Else If Start _
< LBound(Liste) Then Start = LBound(Liste)
If IsMissing(Ende) Then Ende = UBound(Liste) Else If Ende > _
UBound(Liste) Then Ende = UBound(Liste)
If SortOrder = xlAscending Then C = 1 Else C = -1

Ci = 1
Data = Liste
On Error GoTo ErrorHandler

Stack(StackPtr + 1) = Start
Stack(StackPtr + 2) = Ende
StackPtr = StackPtr + 2

Do
StackPtr = StackPtr - 2
Start = Stack(StackPtr + 1)
Ende = Stack(StackPtr + 2)

If Ende - Start < QTHRESH Then
'Insertionsort
Select Case Compare
Case vbDatabaseCompare
'Zahlen sortieren
If SortOrder = xlAscending Then
For J = Start + 1 To Ende
Pivot = Data(J)
Temp = Liste(J)
For i = J - 1 To Start Step -1
If Data(i) <= Pivot Then Exit For
Data(i + 1) = Data(i)
Liste(i + 1) = Liste(i)
Next
Data(i + 1) = Pivot
Liste(i + 1) = Temp
Next
Else
For J = Start + 1 To Ende
Pivot = Data(J)
Temp = Liste(J)
For i = J - 1 To Start Step -1
If Data(i) >= Pivot Then Exit For
Data(i + 1) = Data(i)
Liste(i + 1) = Liste(i)
Next
Data(i + 1) = Pivot
Liste(i + 1) = Temp
Next
End If
Case vbTextCompare
'Texte sortieren => MatchCase:=False
For J = Start + 1 To Ende
Pivot = Data(J)
Temp = Liste(J)
For i = J - 1 To Start Step -1
Ci = StrComp(Data(i), Pivot, Compare)
If Ci <> C Then Exit For
Data(i + 1) = Data(i)
Liste(i + 1) = Liste(i)
Next
Data(i + 1) = Pivot
Liste(i + 1) = Temp
Next
Case vbBinaryCompare
'Texte sortieren => MatchCase:=True
For J = Start + 1 To Ende
Pivot = Data(J)
Temp = Liste(J)
For i = J - 1 To Start Step -1
#If Version = 1 Then
Ci = StrComp(Data(i), Pivot, vbTextCompare)
If Ci = 0 Then If StrComp(Data(i), Data(J), _
vbBinaryCompare) = -C Then Ci = 1
#End If
#If Version = 2 Then
Ci = MyStrComp(Data(i), Pivot)
#End If
If Ci <> C Then Exit For
Data(i + 1) = Data(i)
Liste(i + 1) = Liste(i)
Next
Data(i + 1) = Pivot
Liste(i + 1) = Temp
Next
End Select
Else
'QuickSort
i = Start: J = Ende
Pivot = Data((Start + Ende) \ 2)
Do
Select Case Compare
Case vbDatabaseCompare
'Zahlen sortieren
If SortOrder = xlAscending Then
Do While (Data(i) < Pivot): i = i + 1: Loop
Do While (Data(J) > Pivot): J = J - 1: Loop
Else
Do While (Data(i) > Pivot): i = i + 1: Loop
Do While (Data(J) < Pivot): J = J - 1: Loop
End If

Case vbTextCompare
'Texte sortieren => MatchCase:=False
Ci = StrComp(Data(i), Pivot, Compare)
Do While (Ci = -C)
i = i + 1
Ci = StrComp(Data(i), Pivot, Compare)
Loop
Cj = StrComp(Data(J), Pivot, Compare)
Do While (Cj = C)
J = J - 1
Cj = StrComp(Data(J), Pivot, Compare)
Loop

Case vbBinaryCompare
#If Version = 1 Then
'Texte sortieren => MatchCase:=True
Ci = StrComp(Data(i), Pivot, vbTextCompare)
Do While (Ci = -C)
i = i + 1
Ci = StrComp(Data(i), Pivot, vbTextCompare)
Loop
Cj = StrComp(Data(J), Pivot, vbTextCompare)
Do While (Cj = C)
J = J - 1
Cj = StrComp(Data(J), Pivot, vbTextCompare)
Loop
'Geht nur nach mehrfachem Sortieren:
If Ci = 0 And Cj = 0 Then If StrComp(Data(i), Data( _
J), vbBinaryCompare) = -C Then Ci = 1
#End If
#If Version = 2 Then
Ci = MyStrComp(Data(i), Pivot)
Do While (Ci = -C)
i = i + 1
Ci = MyStrComp(Data(i), Pivot)
Loop
Cj = MyStrComp(Data(J), Pivot)
Do While (Cj = C)
J = J - 1
Cj = MyStrComp(Data(J), Pivot)
Loop
#End If
End Select

If i <= J Then
If i < J And Not (Ci = 0 And Cj = 0) Then
Temp = Liste(i)
Liste(i) = Liste(J)
Liste(J) = Temp
Temp = Data(i)
Data(i) = Data(J)
Data(J) = Temp
End If
i = i + 1: J = J - 1
End If
Loop Until i > J

If (Start < J) Then
'QuickSort Liste, Start, j, Compare, SortOrder
Stack(StackPtr + 1) = Start
Stack(StackPtr + 2) = J
StackPtr = StackPtr + 2
End If
If (i < Ende) Then
'QuickSort Liste, i, Ende, Compare, SortOrder
Stack(StackPtr + 1) = i
Stack(StackPtr + 2) = Ende
StackPtr = StackPtr + 2
End If
End If
Loop Until StackPtr = 0
Exit Sub

ErrorHandler:
If Err.Number = 13 Then
On Error GoTo RepeatError
DoResume = False
'Fehlerwerte können nicht vergleichen werden!
If IsError(Pivot) Then DoResume = True: Pivot = Chr(255) & _
CStr(Pivot)
If IsError(Data(i)) Then DoResume = True: Data(i) = Chr( _
255) & CStr(Data(i))
If IsError(Data(J)) Then DoResume = True: Data(J) = Chr( _
255) & CStr(Data(J))
If DoResume Then
Err.Clear
On Error GoTo ErrorHandler
Else
On Error GoTo 0
End If
Resume
Else
RepeatError:
On Error GoTo 0
Resume
End If
End Sub

[Peter Schleif]

Post by Andreas Killer
und nicht
a
A
ä
Ä
aa
aA
Aa

Das würde ja bedeuten, dass die String-Länge erstes Sortierkriterium
ist. Ein kürzerer String kommt automatisch immer vor einem längeren. Nur
bei gleicher Länge kommt das die Mapping-Tabelle zum Einsatz.

Nur so aus Interesse: Wo findet denn so eine Sortierung Anwendung?

Ich habe die Umlaute in die Mapping-Tabelle aufgenommen und den
String-Längen-Vergleich eingebaut. Damit komme ich auf das obige Ergebnis.

Peter

Function MyStrComp(ByVal s1 As String, ByVal s2 As String)
Dim map(0 To 255) As Integer
Dim i As Integer

For i = 0 To 255
Select Case i
Case 65 To 90, Asc("Ä"), Asc("Ö"), Asc("Ü"): map(i) = i + 32
Case 97 To 122, Asc("ä"), Asc("ö"), Asc("ü"): map(i) = i - 32
Case Else: map(i) = i
End Select
Next

MyStrComp = Sgn(Len(s1) - Len(s2))

If MyStrComp = 0 Then
For i = 1 To Len(s1)
Mid(s1, i, 1) = Chr(map(Asc(Mid(s1, i, 1))))
Next
For i = 1 To Len(s2)
Mid(s2, i, 1) = Chr(map(Asc(Mid(s2, i, 1))))
Next

MyStrComp = StrComp(s1, s2, vbBinaryCompare)
End If
End Function

[Andreas Killer]

Post by Peter Schleif
Das würde ja bedeuten, dass die String-Länge erstes Sortierkriterium
ist. Ein kürzerer String kommt automatisch immer vor einem längeren.
Nur bei gleicher Länge kommt das die Mapping-Tabelle zum Einsatz.

Naja, eigentlich nicht, dann sortierst Du falsch, siehe weiter unten.

Post by Peter Schleif
Nur so aus Interesse: Wo findet denn so eine Sortierung Anwendung?

In jedem Wörterbuch, kuck z.B. mal in den Duden, da findet man die
Reihenfolge:
A,Ä,Å,a,à,Aa,AA,Aachen,Aal,...,ab,Aba,Abakus,abänderlich

Excel sortiert selber diese Reihenfolge wenn man Groß-/Kleinschreibung
beachtet: a,A,ä,Ä,aa,aA

Das ist quasi "Duden" verkehrt herum.

Post by Peter Schleif
Ich habe die Umlaute in die Mapping-Tabelle aufgenommen und den
String-Längen-Vergleich eingebaut. Damit komme ich auf das obige Ergebnis.

Nö, passt immer noch nicht, nun bekomme ich

a
b
A
B
ä
Ä
aa
ab
usw.

Noch eine Idee?

Andreas.

[Peter Schleif]

Post by Andreas Killer
Nö, passt immer noch nicht, nun bekomme ich
a
b
A
B
ä
Ä
aa
ab
usw.

Genau so wolltest Du es haben.

Post by Andreas Killer
a
A
ä
Ä
aa
aA
Aa

Peter

[Andreas Killer]

Post by Peter Schleif
Genau so wolltest Du es haben.

Nu sei doch nicht gleich so, in meinem ersten Posting hab ich's doch
gesagt:

Ich möchte eine Sortroutine die mir Texte mit Beachtung der Groß-/
Kleinschreibung sortiert, wie die Lemmata im Lexikon.

Nimm doch einfach mal die Sub GenListe und sortiere dann die Spalte A
mit Excel ohne Überschrift mit Groß-Kleinschreibung.

Diese Reihenfolge ist mein primäres Ziel, ich denke wenn ich das hab,
dann kann ich danach auch andere Reihenfolgen implementieren.... die
Hoffnung stirbt zuletzt, oder? ;-)

Das das ganze ist nicht ohne ist, ist mir schon klar, wenn man mal im
Internet recherchiert wie wo welche Reihenfolgen bevorzug werden,
"Heiligs Blechle" wie der Schwabe sagt.

Ich bin ja schon sehr froh das ich überhaupt so wie Excel ohne
Groß-/Kleinschreibung sortieren kann.

Andreas.

[Peter Schleif]

Post by Andreas Killer
Ich möchte eine Sortroutine die mir Texte mit Beachtung der Groß-/
Kleinschreibung sortiert

Neee. Möchtest Du nicht. :-)

Zumindest nicht nur. Du möchtest eine Sortierung bei der zunächst eben
NICHT zwischen Groß/Klein unterschieden wird. Erst wenn der Vergleich
OHNE Groß/Klein-Unterscheidung keine Entscheidung bringt, wird als
zweites Kriterium die Reihenfolge a -> A -> ä -> Ä angewendet - also
MIT Beachtung der Groß-/Kleinschreibung

Würdest Du wirklich von Beginn an Groß/Klein beachten wollen, kämmen ja
immer alle Wörter mit "a" am Anfang vor allen Wörtern mit "A" am Anfang.
Aber das willst Du ja anscheinend nicht.


Also zwei Sortier-Schritte:

1. OHNE Groß/Klein-Unterscheidung mit LCase/UCase
2. MIT Groß/Klein-Unterscheidung und Mapping um a <-> A zu tauschen

Natürlich könnte man auch für den ersten Schritt eine eigene
Mapping-Tabelle anlegen, falls außer den Buchstaben noch andere Zeichen
in eine andere Reihenfolge sollen. Ansonsten reicht der normale
Textvergleich.

Function MyStrComp(ByVal s1 As String, ByVal s2 As String)
Dim map(0 To 255) As Integer
Dim i As Integer

For i = 0 To 255
Select Case i
Case 65 To 90, Asc("Ä"), Asc("Ö"), Asc("Ü"): map(i) = i + 32
Case 97 To 122, Asc("ä"), Asc("ö"), Asc("ü"): map(i) = i - 32
Case Else: map(i) = i
End Select
Next

MyStrComp = StrComp(LCase(s1), LCase(s2), vbTextCompare)

If MyStrComp = 0 Then

For i = 1 To Len(s1)
Mid(s1, i, 1) = Chr(map(Asc(Mid(s1, i, 1))))
Next

For i = 1 To Len(s2)
Mid(s2, i, 1) = Chr(map(Asc(Mid(s2, i, 1))))
Next

MyStrComp = StrComp(s1, s2, vbBinaryCompare)

End If
End Function

[Andreas Killer]

Post by Peter Schleif

Post by Andreas Killer
Ich möchte eine Sortroutine die mir Texte mit Beachtung der Groß-/
Kleinschreibung sortiert

Neee. Möchtest Du nicht. :-)

Möchte ich nicht? Hmm, na gut, glaub ich Dir mal. :-))

Post by Peter Schleif
1. OHNE Groß/Klein-Unterscheidung mit LCase/UCase
2. MIT  Groß/Klein-Unterscheidung und Mapping um a <-> A zu tauschen

Genau, so in der Art muss es gehen.

Post by Peter Schleif
Function MyStrComp(ByVal s1 As String, ByVal s2 As String)

Geil, es geht. Vielen Dank. :-))

Andreas.

[Peter Schleif]

Post by Andreas Killer
Möchte ich nicht? Hmm, na gut, glaub ich Dir mal. :-))

Na ja. Der Duden soritiert ja groß/klein auch kunterbunt durcheinander.
Es sei denn, beide Wörter sind LCase-identisch. Dann gilt kleiner vor
größer.

Post by Andreas Killer

Post by Peter Schleif
1. OHNE Groß/Klein-Unterscheidung mit LCase/UCase
2. MIT Groß/Klein-Unterscheidung und Mapping um a<-> A zu tauschen

Genau, so in der Art muss es gehen.

Wobei das zweite Kriterium vermutlich nur sehr selten Anwendung findet.
Wörter die ohne Berücksichtigung der Groß/Kleinschreibung identisch
sind, sich aber trotzdem in (mindestens) einem Buchstaben unterscheiden,
sind schwer zu finden:

- sie/Sie
- wert/Wert
- würde/Würde

Peter