Sortierfunktion
18.11.2019 04:18:36
Steve
ich habe einen Zellbreich mit 13 Spalten und 6 Zeilen, der mit Zeichenketten gefüllt ist.
z.B. BCAE, ACD, EC ,und weitere. Auch leere Zellen sind darunter.
Ich habe mir eine Funktion geschrieben, die mir jede einzelne Zelle alphabetisch sortiert (ABCE, ACD,CE,....)
Leider ist diese sehr langsam. Gibt es eine schnellere Alternative?
Hier die Funktion:
'____________________________________________________________
Public Function SortiereArray(ByRef arrChar() As String) As String()
Dim strTemp As String 'temp. Tauschstring
Dim arrSort() As String 'Sortierarray
Dim lngIndex As Long 'Index des Sortierarrays
Dim blnSortiert As Boolean 'Sortieren beendet? true/false
arrSort = arrChar
Do
blnSortiert = True
For lngIndex = LBound(arrSort) To UBound(arrSort) - 1
If arrSort(lngIndex) > arrSort(lngIndex + 1) Then
blnSortiert = False
strTemp = arrSort(lngIndex)
arrSort(lngIndex) = arrSort(lngIndex + 1)
arrSort(lngIndex + 1) = strTemp
End If
Next lngIndex
Loop Until blnSortiert = True
SortiereArray = arrSort
End Function
'___________________________________________________________
'Hier das Sub zum Aufrufen der Funktion:
Sub Sortieren()
Dim rngC As Range
Dim Text As String
Dim Vergleich As String
Dim Char As Integer
Dim arrChar() As String
Application.ScreenUpdating = False
ActiveSheet.Unprotect
For Each rngC In Range("L11:AP17")
Vergleich = ""
Text = rngC.Value
ReDim arrChar(Len(Text))
For Char = 1 To Len(Text)
arrChar(Char - 1) = Mid(Text, Char, 1)
Next Char
arrChar = SortiereArray(arrChar)
For Char = 1 To Len(Text)
Vergleich = Vergleich & arrChar(Char)
Next Char
rngC.Offset(240, 0).Value = Vergleich
Next rngC
ActiveSheet.Protect , AllowFiltering:=True
Application.ScreenUpdating = True
End Sub