VBA-Quicksort Text mit Groß-/Kleinschreibung

23/07/2010 - 10:17 von Andreas Killer | Report spam
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




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
 

Lesen sie die antworten

#1 Peter Schleif
23/07/2010 - 13:18 | Warnen spam
Andreas Killer schrieb am 23.07.2010 10:17 Uhr:

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. :-)


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

Ähnliche fragen