Shapes sortieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Shapes sortieren

02.09.2015 17:57:03

Alfons

AW: Shapes sortieren

02.09.2015 19:25:08

Matthias

AW: Shapes sortieren

02.09.2015 20:50:21

Patrick

Private Sub AlleEllipsen() Dim wks As Worksheet, wksDummy As Worksheet Dim sha As Shape Dim lngZe As Long Dim varList As Variant 'alle Ovale von links nach rechts durchlaufen Set wks = ActiveSheet Set wksDummy = Worksheets.Add For Each sha In wks.Shapes If sha.AutoShapeType = msoShapeOval Then lngZe = lngZe + 1 wksDummy.Cells(lngZe, 1) = sha.Name wksDummy.Cells(lngZe, 2) = sha.Top wksDummy.Cells(lngZe, 3) = sha.Left 'Debug.Print sha.Name & " -> " & sha.Top & " --- " & sha.Left End If Next 'von links nach rechts: C1 'von oben nach unten: B1 wksDummy.Columns("A:C").Sort Key1:=Range("C1"), _ Order1:=xlAscending ', _ Header:=xlGuess, _ OrderCustom:=1, _ MatchCase:=False, _ Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal With wksDummy varList = .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 3)) End With 'MsgBox UBound(varList) & " Einträge" Application.DisplayAlerts = False wksDummy.Delete Application.DisplayAlerts = True For lngZe = 1 To UBound(varList) 'MsgBox varList(lngZe, 1) 'ShapeName wks.Shapes(varList(lngZe, 1)).Select Stop Next lngZe Erase varList Set wksDummy = Nothing Set wks = Nothing End Sub

Hallo Patrick, hallo Alfons,
ich habs leider nicht ganz so hübsch gestaltet wie Alfons, jedoch die gleiche Grundstrategie gehabt. Deine Lösung ist da durchaus effizienter.
Was mir an deiner (Alfons) Version nicht gefällt, du sortierst zwar von links nach rechts, lässt dabei aber die Höhe völlig außer Acht. Kommt es vor dass Shapes linksbündig am gleichen Zellenrand stehen, wird leider bunt durcheinander selektiert, in der Reihenfolge wie sie eben erstellt wurden. Bei meiner Version ist das in der Berechnung des Ranges gelöst, bei dir müsste man die Sortierung der Horizontalen vor der Sortierung der Vertikalen ergänzen bzw. für "Von oben nach unten" anderes herum.

Sub Shapes_anwaehlen()
Dim ws As Worksheet, wsTmp As Worksheet
Dim x As Long, Counter As Long
Dim sh As Shape
Dim rZelle As Range
Set ws = Tabelle1
' temporäres TB anlegen
Set wsTmp = Worksheets.Add
' Positionen der Shapes übertragen und Formeln eintragen
With wsTmp
For Each sh In ws.Shapes
Counter = Counter + 1
.Cells(Counter, 1).Value = sh.Left
.Cells(Counter, 2).Value = sh.Top
.Cells(Counter, 3).FormulaR1C1 = "=Rank(RC1,C1)+Rank(RC2,C2)%%%+Row()%%%%%%"
.Cells(Counter, 4).FormulaR1C1 = "=Rank(RC3, C3)"
Next sh
ws.Activate
' Suchen des Ranges in Spalte D und entsprechendes Shape auswählen
For x = 1 To Counter
Set rZelle = .Range("D:D").Find(What:=x, LookIn:=xlValues, lookat:=xlWhole)
ws.Shapes(rZelle.Row).Select
' deine gewünschten Aktionen mit dem Shape
Next x
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
End Sub

lg Matthias

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread