Microsoft Excel

Herbers Excel/VBA-Archiv

Sortieren und neu gruppieren

Betrifft: Sortieren und neu gruppieren von: Ingo
Geschrieben am: 25.09.2014 13:09:55

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

  

Betrifft: AW: Sortieren und neu gruppieren von: Rudi Maintaire
Geschrieben am: 25.09.2014 13:22:25

Hallo,
sicher geht das.
Wie soll die Reihenfolge sein?
U1->Y1, U2->Y2, U3->Y3.... oder U1->Y1, U2->Z1, U3->AA1...

Gruß
Rudi


  

Betrifft: AW: Sortieren und neu gruppieren von: Ingo
Geschrieben am: 25.09.2014 13:33:42

Hallo Rudi,
danke für die schnelle Antwort.

Ich denke U1->Y1, U2->Y2, U3->Y3 ist korrekt.

Die Codes stehen ja jetzt in alphab order von Oben nach unten.
Gemäß der Angabe in W2=13 sollen daraus jetzt 9 Spalten werden.
Gemäß der Angabe in W1=12 sollen daraus jetzt 13 Zeilen werden.
Die Sortierung soll so wie in der Liste sein. D.h. Die ersten 13 Zellen aus der sortierten Liste sollen in Y1 bis y13 stehen. Die nächsten 13 in den Zellen z1 bis z13.
Die Sortierung/Reihenfolge soll dabei erhalten bleiben.

Naja, es kann auh vorkommen, das die Anzahl der Spalten und Zeilen verändert wird.
Kriegst du das hin?

Viele Grüße
Ingo



  

Betrifft: AW: Sortieren und neu gruppieren von: Rudi Maintaire
Geschrieben am: 25.09.2014 15:15:51

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

Gruß
Rudi


  

Betrifft: AW: Sortieren und neu gruppieren von: Ingo
Geschrieben am: 25.09.2014 15:22:00

Also das ist ja wieder mal genial.
Ich hätte das so nie hingekriegt.

Vielen, vielen Dank.
Wieder viel gelernt.

Mit freundlichen Grüßen

Ingo


  

Betrifft: AW: Sortieren und neu gruppieren von: Ingo
Geschrieben am: 25.09.2014 15:37:55

Hallo Rudi,
habe es gerade mal getestet, mit veränderten Eingaben.
DA gibt es noch Herausforderungen.
Wenn ich Codes hinzufüge und die Makro starte, bekomme ich eine Fehlermeldung.Runtime Error 9. Subscript out of range.

Das Problem scheint in der Zeile:

arrOut (k;j) = arrTmp (n) zu liegen

k=12
j=1
n=12

Eventuell liegt das aber auch an meinem Makro "MultiSort".
Kannst du da etwas dran machen?

https://www.herber.de/bbs/user/92817.xlsm


Beste Grüße
Ingo


  

Betrifft: AW: Sortieren und neu gruppieren von: Rudi Maintaire
Geschrieben am: 25.09.2014 17:05:46

Hallo,
Eventuell liegt das aber auch an meinem Makro "MultiSort".
brauchst du eigentlich nicht mehr.

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
Gruß
Rudi


  

Betrifft: AW: Sortieren und neu gruppieren von: Ingo
Geschrieben am: 26.09.2014 08:49:48

Guten Morgen Rudi,

jetzt klappt alles super. Einfach perfekt.
Ich finde euch/dich einfach nur klasse.

Vielen vielen Beste Grüßen
Ingo


 

Beiträge aus den Excel-Beispielen zum Thema "Sortieren und neu gruppieren"