Objekte sortieren

Hallo Experten,
ich habe 5 Rechtecke (Rechteck 1 bis Rechteck 5) auf einem Tabellenblatt.
Die Rechtecke sind gleichmäßg angeordnet
Worksheets(1).Shapes(Rechteck 1").Left= 50
Worksheets(1).Shapes(Rechteck 2").Left= 100
Worksheets(1).Shapes(Rechteck 3").Left= 150
Worksheets(1).Shapes(Rechteck 4").Left= 200
Worksheets(1).Shapes(Rechteck 5").Left= 250
Wenn jetzt das Rechteck 3 z.B. nach .Left=230 verschoben wird, sollen die Rechtecke wieder gleichmäßig angeordnet werden, aber Recchteck 3 zwischen 4 und 5 plaziert werden.
Also
Worksheets(1).Shapes(Rechteck 1").Left= 50
Worksheets(1).Shapes(Rechteck 2").Left= 100
Worksheets(1).Shapes(Rechteck 4").Left= 150
Worksheets(1).Shapes(Rechteck 3").Left= 200
Worksheets(1).Shapes(Rechteck 5").Left= 250
Ich möchte also die x-Koordinaten der Rechtecke einlesen und in der entsprechenden Reihenfolge auf die Werte von 50 bis 250 verteilen.
Ich tippe mal auf ein Array, weiß aber nicht wie ich das machen muß :-(
Könnt ihr mir helfen?
Gruß Uppe

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Uppe,
mit einem Array bin ich ausgekommen. Die Ermittlung der neuen Reihenfolge ist dann doch nicht so trivial.
Gruß
Franz

'Code in einem allgemeinen Modul
Option Explicit
Public Type ShapeData
LeftAktuell As Double
LeftTemp As Double
IndexNeu As Integer
objShape As Shape
End Type
Sub NeuPositionieren()
Dim iIndex As Integer, iIndex2 As Integer
Dim myVar() As ShapeData
'Konstanten für Positionieren
Const Pos1_X As Double = 50     'Links-Position des linken Rechtecks
Const Delta_X As Double = 50    'Abstand der linken Ränder der Rechtecke
Const Anzahl As Integer = 4     'Anzahl der Shapes
'Array für Informationen zu den Shapes/Rechtecken deklarieren
ReDim myVar(0 To Anzahl)
For iIndex = 0 To Anzahl
'Shape-Objekte in Array setzen
Set myVar(iIndex).objShape = Worksheets(1).Shapes("Rechteck " & iIndex + 1)
'Aktuelle Position in Array lesen
myVar(iIndex).LeftAktuell = myVar(iIndex).objShape.Left
Next
'Neue Reihenfolge ermitteln
myVar(0).LeftTemp = myVar(0).LeftAktuell
myVar(0).IndexNeu = 0
For iIndex = 1 To Anzahl
myVar(iIndex).LeftTemp = myVar(iIndex).LeftAktuell
myVar(iIndex).IndexNeu = iIndex
For iIndex2 = iIndex - 1 To 0 Step -1
If myVar(iIndex2).LeftTemp > myVar(iIndex).LeftAktuell Then
'Inhalte um 1 richtung Ende der Liste verschieben
myVar(iIndex2 + 1).LeftTemp = myVar(iIndex2).LeftTemp
myVar(iIndex2 + 1).IndexNeu = myVar(iIndex2).IndexNeu
'Vergleichswert und Index für verschobene Einträge eintragen
myVar(iIndex2).LeftTemp = myVar(iIndex).LeftAktuell
myVar(iIndex2).IndexNeu = iIndex
End If
Next
Next
'Rechtecke verschieben
For iIndex = 0 To Anzahl
myVar(myVar(iIndex).IndexNeu).objShape.Left = Pos1_X + iIndex * Delta_X
Next
Erase myVar()
End Sub
Sub OriginalPosition()
'Originalposition der Rechtecke wieder herstellen
Dim iIndex As Integer
Const Pos1_X As Double = 50, Delta_X As Double = 50
For iIndex = 0 To 4
Worksheets(1).Shapes("Rechteck " & Format(iIndex + 1, "0")).Left = Pos1_X + iIndex *  _
Delta_X
Next
End Sub

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread