Nachfolgender Funktion "SortData" werden mit einem 2-dimensionalen VariantArray die Position und das zu sortierende Element übergeben. In vArray(x,0) steht die Position bzw. Satz- oder Stellungsnumer in einer Datendatei, Tabelle oder ähnlichem. In vArray(x,1) steht das zu sortierende Element (z.B. UDT). Man liest die zu sortierende Information in ein Array ein, d.h. nur ein Teil (Element, Spalte usw.) und übergibt es der Funktion. Es wird also weniger Speicher benötigt als wenn man die gesamte Information übergeben würde, was sich in der Geschwindigkeit deutlich bemerkbar macht. Mit dem Rückgabe_Array kann dann beispielsweise aus einer Datei der entsprechende Datensatz [vArray(x,0)] gelesen werden. ' TestAufruf Private Function UnSortData() As Integer Dim A As Integer ' Anzahl Daten Dim I As Integer Dim J As Integer Dim U As Integer Dim Z As Double Dim vArray() As Variant Dim vText As Variant Dim vZeit As Variant Dim vResult As Variant On Error GoTo Err_UnSort A = 100 vResult = InputBox("geben Sie eine Zahl von 100 bis 500 ein", _ "SortierFunktionsTest", A) If vResult = "" Then A = 100 Else A = CLng(vResult) End If ' 2-Dimensionales Variant_Array ReDim vArray(1 To A, 1) ' Beispiel_Daten For I = 1 To A vArray(I, 0) = I ' Position vor Sortieren vArray(I, 1) = (A - I) + 1 Next I ' vorher: 100, 99, 98, 97, ... Z = Timer SortData vArray Z = Timer - Z ' nachher: 1, 2, 3, 4, 5, ... vText = vText & "vArray(X, 0) vArray(X, 1)" & vbCr & vbCr For I = 1 To A J = vArray(I, 0) ' Position nach Sortieren If I <= 10 Then vText = vText & J & Space(15) & vArray(I, 1) & vbCr Else Exit For End If Next I vZeit = Format(Z, "0.00") vZeit = vZeit & " sec" vText = vText & vbCr & vZeit MsgBox vText, vbInformation, "Sortierte Daten" ' Windows XP, Microsoft Network ' ' Zeiten ' A=500 : 3.61 sec ' A=400 : 1.88 sec ' A=300 : 0.80 sec ' A=200 : 0.23 sec ' A=100 : 0.03 sec Exit_UnSort: Exit Function Err_UnSort: MsgBox Err & vbCr & Err.Description, , "UnSortData" Resume Exit_UnSort End Function ' Um große Datenmengen zu sortieren, z.B. aus Dateien, Tabellen, usw., ' wird der zu sortierende Begriff (Element o. Spaltenwert) mit seiner ' Position(Stellung) in einem 2-dimensionalen varArray an diese ' Funktion übergeben. ' ' Die Funktion sortiert den Begriff(vArray(X,1) und gibt quasi die ' Position(vArray(X,0) zurück. ' ' Algorithmus: abgewandeltes Austauschverfahren: ' sortiert aufsteigend (>) ' Function SortData(vArray As Variant) As Long Dim A As Variant Dim B As Variant Dim C As Long Dim I As Long Dim J As Long Dim K As Long Dim L As Long Dim UB As Long Dim Z As Long Dim Min As Long Dim min0 As Variant Dim min1 As Variant Dim LX() As Variant On Error GoTo Err_SortData UB = UBound(vArray) L = UB ReDim LX(1 To L, 1) ' dimensionieren, temp.Array For I = 1 To L ' einlesen LX(I, 0) = vArray(I, 0) ' Position, SatzNr LX(I, 1) = vArray(I, 1) ' zu sort.Begriff Next I ' #Sort Do K = 0 For I = 1 To L Min = I A = LX(I, 1) ' zu sort.Begriff For J = I + 1 To L B = LX(J, 1) ' tausche wenn B < A If B < A Then Min = J K = J Exit For End If Next J If Min > I Then min0 = LX(Min, 0) min1 = LX(Min, 1) LX(Min, 0) = LX(I, 0) LX(Min, 1) = LX(I, 1) LX(I, 0) = min0 LX(I, 1) = min1 End If Next I Z = Z + 1 Loop Until K = 0 For I = 1 To L ' rückschreiben vArray(I, 0) = LX(I, 0) vArray(I, 1) = LX(I, 1) Next I ' #Sort Exit_SortData: Erase LX Exit Function Err_SortData: ' ErrDatei Err, MODASSI & "SortData" MsgBox Err.Number & vbcr & Err.Description Resume Exit_SortData End Function |