Gruppierung aus Formen verschieben

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Candy,
ich habe einen Namen "Bilder" (kannst du auch anders festlegen) erstellt, wobei der Bezug wie folgt definiert ist:
=INDEX(Tabelle1!$A$2:$B$9;VERGLEICH(Tabelle2!$J$4;Tabelle1!$A$2:$A$9;0);2)
Der Teil VERGLEICH(Tabelle2!$J$4;Tabelle1!$A$2:$A$9;0) sucht die Zeile in Tabelle1 in A2:A9, welche dem Inhalt (Nummer) aus Zelle J4 entspricht und der INDEX gibt dann den Inhalt der Zelle aus dieser Zeile aber in Spalte B (deshalb ;2 am Ende der Formel) wieder - auf dieser Zelle liegt das gesuchte Bild.
Dann habe ich eine Zelle kopiert und über Einfügen -&gt Inhalte einfügen als verknüpfte Grafik auf die Zellen A25:A28 in der benötigsten Größe gelegt - dort soll das richtige Bild dann angezeigt werden. Damit dies möglich ist, habe ich der verknüpften Grafik den definierten Namen "Bilder" zugewiesen, indem ich in die Bearbeitungsleiste die Formel =Bilder eingetragen habe.

Sub BildKopieren() Dim rngZelle As Range Dim shaShape As Shape Set rngZelle = Worksheets("Tabelle1").Columns(1).Find(Worksheets("Tabelle2").Range("J4"), _ lookat:=xlWhole) If Not rngZelle Is Nothing Then For Each shaShape In Worksheets("Tabelle2").Shapes If shaShape.TopLeftCell.Address(False, False) = "A25" Then shaShape.Delete End If Next shaShape For Each shaShape In Worksheets("Tabelle1").Shapes If shaShape.TopLeftCell.Address = rngZelle.Offset(0, 1).Address Then shaShape.Copy Worksheets("Tabelle2").Range("A25").PasteSpecial Paste:=xlAll Exit For End If Next shaShape End If End Sub

Hi Candy,
so sollte es als Gruppierung eingefügt werden:

Sub BildKopieren()
Dim rngZelle As Range
Dim shaShape As Object
Application.ScreenUpdating = False
Set rngZelle = Worksheets("Tabelle2").Columns(1).Find( _
Worksheets("Tabelle1").Range("J5"), lookat:=xlWhole)
If Not rngZelle Is Nothing Then
For Each shaShape In Worksheets("Tabelle1").Shapes
If shaShape.Name Like "Group*" Then
shaShape.Delete
Exit For
End If
Next shaShape
For Each shaShape In Worksheets("Tabelle2").Shapes
If shaShape.Name Like "Group*" Then
If shaShape.TopLeftCell.Address = rngZelle.Offset(0, 1).Address Then
shaShape.Copy
Worksheets("Tabelle1").Paste
With Worksheets("Tabelle1")
With .Shapes(Worksheets("Tabelle1").Shapes.Count)
.Top = .Parent.Rows(26).Top
.Left = .Parent.Columns(6).Left
End With
End With
Exit For
End If
End If
Next shaShape
End If
Application.ScreenUpdating = True
End Sub

Beliebteste Forumthreads (12 Monate)

Gruppierung aus Formen verschieben

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread