AW: Automatisches Ordnen nach Alphabet und Zahlen
22.09.2016 13:10:44
Rudi
Hallo,
teste mal:
Sub SortierMich()
Dim i As Long, j As Long, n As Long, c As Long, arr(), arrOut()
Dim lRows As Long, lColumns As Long
lColumns = Cells(1, Columns.Count).End(xlToLeft).Column '- 3 wenn letzte Spalte nicht
lRows = Cells(Rows.Count, 1).End(xlUp).Row
ReDim arr(1 To WorksheetFunction.CountA(ActiveSheet.Columns(1).Resize(, lColumns)))
For i = 1 To lColumns Step 3
For j = 1 To Cells(Rows.Count, i).End(xlUp).Row
n = n + 1
arr(n) = Cells(j, i)
Next
Next
QuickSort arr
ReDim arrOut(1 To lRows, 1 To lColumns)
n = 0
c = 1
For i = 1 To UBound(arr)
n = n + 1
arrOut(n, c) = arr(i)
If i Mod lRows = 0 Then
n = 0
c = c + 3
End If
Next
Cells(1, 1).Resize(lRows, lColumns) = arrOut
End Sub
Sub QuickSort(ByRef DasArray, Optional ErsteZeile, Optional LetzteZeile)
On Error Resume Next
Dim UnterGrenze As Long, OberGrenze As Long
Dim AktuellerWert, GemerkterWert As Variant
If IsMissing(ErsteZeile) Then
ErsteZeile = LBound(DasArray)
End If
If IsMissing(LetzteZeile) Then
LetzteZeile = UBound(DasArray)
End If
UnterGrenze = ErsteZeile
OberGrenze = LetzteZeile
AktuellerWert = DasArray((ErsteZeile + LetzteZeile) / 2)
Do While (UnterGrenze AktuellerWert And OberGrenze > ErsteZeile)
OberGrenze = OberGrenze - 1
Loop
If (UnterGrenze ErsteZeile) Then Call QuickSort(DasArray, ErsteZeile, OberGrenze)
If (UnterGrenze
Gruß
Rudi