Automatisches Ordnen nach Alphabet und Zahlen

NLS · 2016-09-22T07:51:58+00:00

Guten Morgen, ich würde gern automatisch den Inhalt der angehangenen Tabelle geordnet bekommen. Die Tabelle wird per copy und paste gefüllt und anschließend weitergegeben an eine andere Abteilung, die den Inhalt möglichst geordnet ausdruckt und damit arbeiten wird. welche Möglichkeiten gibt es da? https://www.herber.de/bbs/user/108335.xlsx DANKE

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

Hi Fennek,
hab's gleich mal getestet, und es tut brav.
Aber beim Test mit 20000 Spieldaten ...

Sub DatenErzeugen()
Dim a$(1 To 20000, 1 To 1)
Dim i&, k&, s$
Dim t0 As Single, t1 As Single
t0 = Timer
Randomize
For i = 1 To 20000
s = Chr(Int(Rnd() * 26 + 65))
For k = 1 To 5
s = s & Chr(Int(Rnd() * 26 + 65))
Next
a(i, 1) = s
Next
Range("A1").Resize(UBound(a)) = a
t1 = Timer
MsgBox "t1-t0: " & (t1 - t0) * 1000
End Sub
Sub Fennek()
Dim i&, z&, a, aa
Dim t0 As Single, t1 As Single
t0 = Timer
a = Range("A1:A20000")
aa = a
With CreateObject("system.collections.arraylist")
For i = 1 To UBound(a)
.Add a(i, 1)
Next
.Sort
'  Debug.Print Join(.toarray(), "; "), .gethashcode
a = .toarray
End With
For i = LBound(a) To UBound(a): aa(i + 1, 1) = a(i): Next
Range("A1:A20000") = aa
t1 = Timer
MsgBox "t1-t0: " & (t1 - t0) * 1000
End Sub
Sub CopySort()
Dim i&, z&, a, aa
Dim t0 As Single, t1 As Single
t0 = Timer
Range("A1:A20000").Copy Range("B1")
Range("B1:B20000").Sort Range("B1"), xlAscending, Header:=xlNo
Range("B1:B20000").Copy Range("A1")
t1 = Timer
MsgBox "t1-t0: " & (t1 - t0) * 1000
End Sub

...benötigt der untere Code etwa die Hälfte der Zeit. Die Crux ist, daß ich (bis auf Weiteres) davon ausgehe, daß .toarray ein eindimensionales Array ausspuckt, das man so nicht direkt zurückschreiben kann.
redim aa statt aa=a ist unverändert, transpose hab ich nicht getestet.
Schöne Grüße,
Michael

Automatisches Ordnen nach Alphabet und Zahlen

Forumthread: Automatisches Ordnen nach Alphabet und Zahlen

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Automatisches Ordnen nach Alphabet und Zahlen

Forumthread: Automatisches Ordnen nach Alphabet und Zahlen

20 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread