Listen sortieren und neu anordnen per Makro

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

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

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

Beliebteste Forumthreads (12 Monate)

Listen sortieren und neu anordnen per Makro

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread