Microsoft Excel

Herbers Excel/VBA-Archiv

Listen sortieren und neu anordnen per Makro

Betrifft: Listen sortieren und neu anordnen per Makro von: Ingo
Geschrieben am: 24.09.2014 09:04:05

Guten Morgen,
schon wieder bin ich auf eine Herausforderung gestossen. Ich hoffe ihr könnt helfen.

Eine Excel Liste mit 3 Spalten, mit Header, und 20 Zeilen Zeilen, C7:e26, soll sortiert werden, von klein nach groß, basierend auf Spalte E.
Die Range C8:E8 soll dann nach Feld H8 gemoved werden, die Range C9:e9)nach L8. Die Zellinhalte stehen also dann nebeneinander mit einer leeren Zelle (K) dazwischen.

Danach soll die Liste neu sortiert werden, wieder auf der Basis Spalte E. Aber diesmal von groß nach klein. Die Zellen aus Spalte C,D,E sollen dann bewegt werden. Wie gehabt in Spalte H und L, sodass sie sich paarweise in einer Zeile anordnen.

Die Excelliste, die hier sortiert werden soll kann durchaus bis zu 200 Zeilen haben.

Ich habe mal ein Muster hochgeladen.
https://www.herber.de/bbs/user/92782.xlsm

Vielen Dank für euren Input im Voraus
Mit freundlichen Grüßen

Ingo


  

Betrifft: Liste umsortieren und umordnen - VBA von: Erich G.
Geschrieben am: 24.09.2014 11:44:08

Hi Ingo,
das ginge wohl auch mit Formeln, aber du wolltest ja eher VBA.

Dabei ist nur ein Sortiervorgang nötig. Probier mal:

Option Explicit

Sub UmSortOrg()
   Dim lngZ As Long, arQ, qq As Long, zz As Long, cc As Long, arZ()

   With ActiveWorkbook.Worksheets("Sheet1")           ' Sortieren
      With .Sort
         .SortFields.Clear
         .SortFields.Add Key:=Range("E8:E26"), Order:=xlDescending
         .SetRange Range("C7:E26")
         .Header = xlYes
         .Orientation = xlTopToBottom
        .Apply
      End With

      lngZ = .Cells(.Rows.Count, 3).End(xlUp).Row - 7 ' Anz. Quellzeilen
      arQ = .Cells(8, 3).Resize(lngZ, 3)              ' Quelldaten in Array
      ReDim arZ(1 To lngZ / 2, 1 To 7)
      For cc = 1 To 3                                 ' Zieldaten erzeugen
         arZ(1, cc) = arQ(lngZ, cc)
         arZ(1, cc + 4) = arQ(lngZ - 1, cc)
         zz = 1
         For qq = 1 To lngZ - 2
            If qq Mod 2 = 1 Then
               zz = zz + 1
               arZ(zz, cc) = arQ(qq, cc)
            Else
               arZ(zz, cc + 4) = arQ(qq, cc)
            End If
         Next qq
      Next cc                                         ' Zieldaten in Blatt
      .Cells(8, 8).Resize(UBound(arZ), UBound(arZ, 2)) = arZ

'     .Cells(8, 3).Resize(lngZ, 3).ClearContents      ' Quelldaten löschen
   End With
End Sub
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich


  

Betrifft: AW: Liste umsortieren und umordnen - VBA von: Ingo
Geschrieben am: 24.09.2014 11:50:55

Hallo Erich,

das funktioniert super. Eingefügt und los. Bin wieder einmal beeindruckt.
Sag mal, ist es möglich rechts bzw links der neuen Zellen jeweiles eine kleine Grafik auftauchen zu lassen, wenn die Zelle gefüllt wurde? (hier: Auto). (Oder soll ich dafür einen neuen Thread aufmachen?).

Vielen vielen herzlichen Dank

Mit freundlichen Grüßen

Ingo Hindersmann


  

Betrifft: AW: Liste umsortieren und umordnen - VBA von: Ingo
Geschrieben am: 24.09.2014 11:54:27

Hallo Erich,
habe da noch eine kleine Frage:

Im Sortbereich schreibst du:

With ActiveWorkbook.Worksheets("Sheet1") ' Sortieren
With .Sort
.SortFields.Clear
.SortFields.Add Key:=Range("E8:E26"), Order:=xlDescending
.SetRange Range("C7:E26")

Was ist denn, wenn die Liste länger wird, und aus E26 vielleicht E226 wird?
Berücksichtigt das Makro das?

Mit besten Grüßen
Ingo


  

Betrifft: AW: Liste umsortieren und umordnen - VBA von: Ingo
Geschrieben am: 24.09.2014 12:33:41

Hallo Erich,
habe da noch eine kleine Frage:

Im Sortbereich schreibst du:

With ActiveWorkbook.Worksheets("Sheet1") ' Sortieren
With .Sort
.SortFields.Clear
.SortFields.Add Key:=Range("E8:E26"), Order:=xlDescending
.SetRange Range("C7:E26")

Was ist denn, wenn die Liste länger wird, und aus E26 vielleicht E226 wird?
Berücksichtigt das Makro das?

Mit besten Grüßen
Ingo


  

Betrifft: Sort variabler von: Erich G.
Geschrieben am: 24.09.2014 12:46:08

Hi Ingo,
sorry, da hatte ich gar nicht richtig hingeschaut, nur den Makroaufzeichner schreiben lassen ...

Hier eine neue, hoffentlich bessere Variante:

Option Explicit

Sub UmSortOrg()
   Dim lngZ As Long, arQ, qq As Long, zz As Long, cc As Long, arZ()

   With ActiveWorkbook.Worksheets("Sheet1")           ' Sortieren
      lngZ = .Cells(.Rows.Count, 3).End(xlUp).Row - 7 ' Anz. Quellzeilen
      With .Sort
         .SortFields.Clear
         .SortFields.Add Key:=Range("E8:E" & lngZ), Order:=xlDescending
         .SetRange Range("C7:E" & lngZ)
         .Header = xlYes
         .Orientation = xlTopToBottom
        .Apply
      End With

      arQ = .Cells(8, 3).Resize(lngZ, 3)              ' Quelldaten in Array
      ReDim arZ(1 To lngZ / 2, 1 To 7)
      For cc = 1 To 3                                 ' Zieldaten erzeugen
         arZ(1, cc) = arQ(lngZ, cc)
         arZ(1, cc + 4) = arQ(lngZ - 1, cc)
         zz = 1
         For qq = 1 To lngZ - 2
            If qq Mod 2 = 1 Then
               zz = zz + 1
               arZ(zz, cc) = arQ(qq, cc)
            Else
               arZ(zz, cc + 4) = arQ(qq, cc)
            End If
         Next qq
      Next cc                                         ' Zieldaten in Blatt
      .Cells(8, 8).Resize(UBound(arZ), UBound(arZ, 2)) = arZ

'     .Cells(8, 3).Resize(lngZ, 3).ClearContents      ' Quelldaten löschen
   End With
End Sub
Was die Grafik betrifft:
Wie könnte ich darauf jetzt antworten? Ich weiß nichts darüber, außer "klein", "Auto" (was auch immer
das hier bedeutet) und dass sie derzeit abgetaucht ist oder sind (sonst könnten(n) sie ja nicht
auftauchen... :-)) Und geht es um eine oder viele Grafiken?
Wo ist dabei deine Frage, dein Problem? Hast du es mal mit der Makroaufzeichnung probiert?
Ich meine, nur zu kannst beurteilen, ob sich ein neuer Thread lohnt.

Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich


  

Betrifft: AW: Sort variabler von: Ingo
Geschrieben am: 24.09.2014 12:56:38

Haha, ist klar. War sehr kryptisch. Stimmt.
Also, die Liste, die wir mit deinem Supermakro trennen und neu aufstellen, beschreibt das Lineup von Paketfahrzeugen an einem Sortierband. Am Anfang stehen immer die beiden, die die wenigsten Pakete abnehmen müssen. Danach kommen die am stärksten belasteten Fahrzeuge, in abnehmender Reihenfolge. Sehr viele Leute begreifen das nicht. deshalb will ich ihnen ein kleines Tool zur verfügung stellen, das ihnen bei diesem Lineup hilft. Da der Mensch in Bildern denkt, wollte ich dann neben den Routennamen "MAN1A" etc. das Bild eines Zustellfahrzeugs (Sprinter, gelb) als .jpg erscheinen lassen. Und klein, deshalb, weil es nicht höher sein darf als die Zeile. Für Doofe. Wenn ich das über ein Macro aufzeichne, habe ich das Problem, das das nur einmal funktioniert, da die Grafik, das Objekt, immer einen neuen Namen bekommt.
Fällt dir dazu etwas ein?

Beste Grüße
Ingo


  

Betrifft: AW: Sort variabler von: Ingo
Geschrieben am: 24.09.2014 13:04:55

Hallo Erich,
ich habe gerade das neue Makro getestet.
An der Stelle:

arZ(1, cc + 4) = arQ(lngZ - 1, cc)
zz = 1
For qq = 1 To lngZ - 2
If qq Mod 2 = 1 Then
zz = zz + 1
-----------> arZ(zz, cc) = arQ(qq, cc) <-------------
Else

bleibt es hängen und der Debugger geht auf.
Was kann das sein?

Beste Grüße
Ingo


  

Betrifft: Fehlermeldung von: Erich G.
Geschrieben am: 24.09.2014 13:19:00

Hi Ingo,
"bleibt es hängen und der Debugger geht auf": Könntest du nicht gleich noch etwas mehr über den Fehler mitteilen?
Ich sehe jetzt nur, in welcher Zeile ein Fehler auftritt.

Es gibt da wohl eine Fehlernummer, und es gibt einen Fehlertext.

Und wenn du mit der Maus über die Variablen in der Fehlerzeile fährst, siehst du sehr schön, welche Werte
die Variablen (qq, zz, cc, arQ(qq,cc), ...) gerade haben. All das wäre interessant für die Fehleranalyse.
Bei mir läuft das fehlerlos durch...

Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich


  

Betrifft: AW: Fehlermeldung von: Ingo
Geschrieben am: 24.09.2014 13:27:46

Hallo Erich,

es sagt:
Runtimefehler 09
Subscript out of range.

Habe die Meldung als Pic in das Excel eingefügt.

Hier die Werte:

arZ(zz, cc) = arQ(qq, cc)
zz = 15
cc = 1
qq = 27

und hier der file:
https://www.herber.de/bbs/user/92788.xlsm

Beste Grüße
Ingo


  

Betrifft: Korrektur von: Erich G.
Geschrieben am: 24.09.2014 13:37:44

Hi Ingo,
sorry - da hatte ich wohl einen Fehler wieder eingebaut.

Änder mal die Zeile
ReDim arZ(1 To lngZ / 2, 1 To 7)
in
ReDim arZ(1 To (lngZ + 1) / 2, 1 To 7)

Dann sollte es laufen.

Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich


  

Betrifft: AW: Korrektur von: Ingo
Geschrieben am: 24.09.2014 13:42:19

Ja. Jetzt ja.
ist irgendwie ein bischen wie schwarze Magie. Aber gut. Sehr gut.
Hattest du noch ne Idee zu den Autos?

Vielen vielen Dank
Ingo


  

Betrifft: AW: Korrektur von: Ingo
Geschrieben am: 24.09.2014 13:57:31

Hallo Erich,

sag mir bitte Bescheid, wenn ich Anfange lästig zu werden.
In dem geänderten Makro funktioniert das Umbauen, von untereinander zu nebeneinander in Paaren ganz gut. Ich habe jetzt festgestellt, das die Sortierung, wie du sie am Anfang eingerichtet hattest nicht mehr funzt.
In den beiden ersten Zeilen der neuen Tabelle sollen die Datensätze auftauchen, die am wenigsten "Pieces" haben. In den dann folgenden Zeilen sollen alle anderen Datensätze dann von "meiste Pieces" nach "wenigste Pieces" gelistet werden.
Es wäre ganz toll, wenn du dafür eine Lösung hast.

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


Beste Grüße
Ingo


  

Betrifft: neue Korrektur von: Erich G.
Geschrieben am: 24.09.2014 14:51:16

Hi Ingo,
du wirst nicht lästig! Wenn ich Fehler produziere, muss ich auch versuchen, sie aus der Welt zu räumen.

Hier mein nächster Versuch:

Sub UmSortOrg()
   Dim lngZ As Long, arQ, qq As Long, zz As Long, cc As Long, arZ()

   With ActiveWorkbook.Worksheets("Sheet1")           ' Sortieren
      lngZ = .Cells(.Rows.Count, 3).End(xlUp).Row     ' Quellzeilen bis
      With .Sort
         .SortFields.Clear
         .SortFields.Add Key:=Range("E8:E" & lngZ), Order:=xlDescending
         .SetRange Range("C7:E" & lngZ)
         .Header = xlYes
         .Orientation = xlTopToBottom
         .Apply
      End With
      lngZ = lngZ - 7                                 ' 7 Zeilen Überschrift
      arQ = .Cells(8, 3).Resize(lngZ, 3)              ' Quelldaten in Array
      ReDim arZ(1 To (lngZ + 1) / 2, 1 To 7)
      For cc = 1 To 3                                 ' Zieldaten erzeugen
         arZ(1, cc) = arQ(lngZ, cc)
         arZ(1, cc + 4) = arQ(lngZ - 1, cc)
         zz = 1
         For qq = 1 To lngZ - 2
            If qq Mod 2 = 1 Then
               zz = zz + 1
               arZ(zz, cc) = arQ(qq, cc)
            Else
               arZ(zz, cc + 4) = arQ(qq, cc)
            End If
         Next qq
      Next cc                                         ' Zieldaten in Blatt
      .Cells(8, 8).Resize(UBound(arZ), UBound(arZ, 2)) = arZ

'     .Cells(8, 3).Resize(lngZ, 3).ClearContents      ' Quelldaten löschen
   End With
End Sub
Das Problem war, dass ich die 7 Zeilen oberhaöb der 1. Datenzeile in lngZ nicht richtig berücksichtigt habe.
Sorry!

Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich


  

Betrifft: AW: neue Korrektur von: Ingo
Geschrieben am: 24.09.2014 15:05:36

Super Duperklassemegageil.
Jetzt klappt alles. Position. Reihenfolge. Menge. Alles gut Vielen vielen Dank.
Können wir auch noch mal über die Autos reden? Muster anbei.

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


Beste Grüße
Ingo


 

Beiträge aus den Excel-Beispielen zum Thema "Listen sortieren und neu anordnen per Makro"