Sortieren und neu gruppieren

Hallo ihr Lieben,
ein neuer Tag, eine neue Herausforderung, eine neue Chance ein Held zu werden.
Heute schreibe ich entnervt über Listensortieren.
Ich habe da eine Liste mit Codes. Die Codes stehen in einer Range von A1 bis I13.(kann aber auch länger sein, zB. A1 bis I20).
Also 117. Ich habe, mit der Hilfe der Beispiele, jetzt ein Macro zusammengebastelt, das mir alle Codes alphabetisch sortiert in Spalte U ausgibt. Soweit so gut.
Jetzt soll aus dieser 1-spaltigen Liste aber wieder eine Matrix werden. Die Anzahl der Zeilen wird in in W1 vorgegeben, die Anzahl der Spalten in W2.
Die Matrix kann gerne irgendwo rechts auftauchen, zB. Y1.
Geht das über ein Makro?
https://www.herber.de/bbs/user/92809.xlsm
Ich freue mich auf eure Antworten.
Im Voraus vielen Dank
Ingo

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,

Sub aaaa()
Dim arrIn, arrTmp(), arrOut()
Dim i As Long, j As Long, n As Long, k As Long
Dim lZeilen As Long, lSpalten As Long
lZeilen = Range("W1")
arrIn = Cells(1, 1).CurrentRegion
ReDim arrTmp(1 To UBound(arrIn) * UBound(arrIn, 2))
lZeilen = Range("W1")
lSpalten = WorksheetFunction.RoundUp(UBound(arrTmp) / lZeilen, 0)
For i = 1 To UBound(arrIn)
For j = 1 To UBound(arrIn, 2)
n = n + 1
arrTmp(n) = arrIn(i, j)
Next
Next
n = 0
j = 0
QuickSort arrTmp
ReDim arrOut(1 To lZeilen, 1 To lSpalten)
For i = 1 To UBound(arrTmp) Step lZeilen
j = j + 1
k = 0
For n = i To i + 12
k = k + 1
arrOut(k, j) = arrTmp(n)
Next
Next
Range("Y1").Resize(lZeilen, lSpalten) = arrOut
End Sub

Sub QuickSort(ByRef DasarrIny, 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(DasarrIny)
End If
If IsMissing(LetzteZeile) Then
LetzteZeile = UBound(DasarrIny)
End If
UnterGrenze = ErsteZeile
OberGrenze = LetzteZeile
AktuellerWert = DasarrIny((ErsteZeile + LetzteZeile) / 2)
Do While (UnterGrenze  AktuellerWert And OberGrenze > ErsteZeile)
OberGrenze = OberGrenze - 1
Loop
If (UnterGrenze  ErsteZeile) Then Call QuickSort(DasarrIny, ErsteZeile, OberGrenze)
If (UnterGrenze

Gruß
Rudi

Sub aaaa() Dim arrIn, arrTmp(), arrOut() Dim i As Long, j As Long, n As Long, k As Long Dim lZeilen As Long, lSpalten As Long lZeilen = Range("W1") arrIn = Cells(1, 1).CurrentRegion ReDim arrTmp(1 To UBound(arrIn) * UBound(arrIn, 2)) lZeilen = Range("W1") lSpalten = WorksheetFunction.RoundUp(UBound(arrTmp) / lZeilen, 0) For i = 1 To UBound(arrIn) For j = 1 To UBound(arrIn, 2) n = n + 1 arrTmp(n) = arrIn(i, j) Next Next n = 0 j = 0 QuickSort arrTmp ReDim arrOut(1 To lZeilen, 1 To lSpalten) For i = 1 To UBound(arrTmp) Step lZeilen j = j + 1 k = 0 For n = i To WorksheetFunction.Min(i + lZeilen - 1, UBound(arrTmp)) k = k + 1 arrOut(k, j) = arrTmp(n) Next Next Range("Y1").Resize(lZeilen, lSpalten) = arrOut End Sub

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

34 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Sortieren und neu gruppieren

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

34 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread