QuickSortArray tut es nicht
17.12.2023 11:59:43
Reiner
ich habe ein Array sauber gefüllt mit der Dimension arrWerte(9, 550).
Dieses möchte ich mit QuickSortArray sortieren lassen und dann in einer Userform mit mehreren Textfeldern ausgeben lassen.
Es klappt auch alles, nur, es wird NICHT sortiert.
Der Aufruf lautet
QuickSortArray Werte, , , 1 (es soll nach der ersten Spalte sortiert werden, aber auch mit anderen Spalten klappt es nicht)
Nachfolgend das Statement, in dessen Ergebnis varMid leer bleibt und die Sortierung übergangen wird.
varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)
Was muss, kann ich besser machen?
Danke Reiner
Nachfolgend nochmal besagte Sortierroutine:
Public Sub QuickSortArray(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0)
Application.ScreenUpdating = False
On Error GoTo ErrorProcessing
'Sort a 2-Dimensional array
' SampleUsage: sort arrData by the contents of column 3 '
' QuickSortArray arrData, , , 3 '
'Posted by Jim Rech 10/20/98 Excel.Programming
'Modifications, Nigel Heffernan: '
' Escape failed comparison with empty variant '
' Defensive coding: check inputs
Dim i As Long
Dim j As Long
Dim varMid As Variant
Dim arrRowTemp As Variant
Dim lngColTemp As Long
If IsEmpty(SortArray) Then
Exit Sub
End If
If InStr(TypeName(SortArray), "()") 1 Then
'IsArray() is somewhat broken: Look for brackets in the type name
Exit Sub
End If
If lngMin = -1 Then
lngMin = LBound(SortArray, 1)
End If
If lngMax = -1 Then
lngMax = UBound(SortArray, 1)
End If
If lngMin >= lngMax Then
' no sorting required
Exit Sub
End If
i = lngMin
j = lngMax
varMid = Empty
varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)
' We send 'Empty' and invalid data items to the end of the list:
If IsObject(varMid) Then
' note that we don't check isObject(SortArray(n)) - varMid *might* pick up a valid default member or property
i = lngMax
j = lngMin
ElseIf IsEmpty(varMid) Then
i = lngMax
j = lngMin
ElseIf IsNull(varMid) Then
i = lngMax
j = lngMin
ElseIf varMid = "" Then
i = lngMax
j = lngMin
ElseIf VarType(varMid) = vbError Then
i = lngMax
j = lngMin
ElseIf VarType(varMid) > 17 Then
i = lngMax
j = lngMin
End If
While i = j
While SortArray(i, lngColumn) varMid And i lngMax
i = i + 1
Wend
While varMid SortArray(j, lngColumn) And j > lngMin
j = j - 1
Wend
If i = j Then
' Swap the rows
ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
Next lngColTemp
Erase arrRowTemp
i = i + 1
j = j - 1
End If
Wend
If (lngMin j) Then Call QuickSortArray(SortArray, lngMin, j, lngColumn)
If (i lngMax) Then Call QuickSortArray(SortArray, i, lngMax, lngColumn)
Exit Sub
ErrorProcessing:
MsgBox "Fehler in Quicksortarray: " & vbCrLf & Err.Number & vbCrLf & Err.Description
If Application.UserName = "Rxxxxx" Or Environ$("Computername") = "xxx" Then
Stop
Resume
End If
End Sub