AW: Grafiken an bestimmter Stelle
Ramses
Hallo
hier mal ein Script.
Die Grafiken müssen im Namensfeld den Namen "Bild 1" und "Bild 2" haben.
Rotieren lässt sich die Grafik nicht, weil die Bildbereich beim drehen sonst über den zu positionierenden Bereich hinausragen, wenn die Grafik nicht skaliert wird.
Aber dieses Gimmick übersteigt den Aufwand hier im Forum.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sh1 As Shape, sh2 As Shape
Set sh1 = ActiveSheet.Shapes("Picture 1")
Set sh2 = ActiveSheet.Shapes("Picture 2")
Select Case Target.Address(False, False)
Case "J1", "K1", "L1"
ActiveSheet.Shapes("Picture 1").Visible = False
ActiveSheet.Shapes("Picture 2").Visible = False
Select Case Target.Address(False, False)
Case "J1"
If Target.Value = 1 Then
With sh1
.Visible = True
.Top = 0
.Left = 0
.Height = ([a1].RowHeight + [a2].RowHeight + [a3].RowHeight) * 5.67
.Width = [a1].ColumnWidth * 5.67
End With
End If
If Target.Value = 2 Then
With sh2
.Visible = True
.Top = 0
.Left = 0
.Height = ([a1].RowHeight + [a2].RowHeight + [a3].RowHeight) * 5.67
.Width = [a1].ColumnWidth * 5.67
End With
End If
Case "K1"
If Target.Value = 1 Then
With sh1
.Visible = True
.Top = 0
.Left = [a1].ColumnWidth * 5.67
.Height = ([a1].RowHeight + [a2].RowHeight + [a3].RowHeight) * 5.67
.Width = [a1].ColumnWidth * 5.67
End With
End If
If Target.Value = 2 Then
With sh2
.Visible = True
.Top = 0
.Left = [a1].ColumnWidth * 5.67
.Height = ([a1].RowHeight + [a2].RowHeight + [a3].RowHeight) * 5.67
.Width = [a1].ColumnWidth * 5.67
End With
End If
Case "L1"
If Target.Value = 1 Then
With sh1
.Visible = True
.Top = 0
.Left = ([a1].ColumnWidth + [B1].ColumnWidth) * 5.67
.Height = ([a1].RowHeight + [a2].RowHeight + [a3].RowHeight) * 5.67
.Width = [a1].ColumnWidth * 5.67
End With
End If
If Target.Value = 2 Then
With sh2
.Visible = True
.Top = 0
.Left = ([a1].ColumnWidth + [B1].ColumnWidth) * 5.67
.Height = ([a1].RowHeight + [a2].RowHeight + [a3].RowHeight) * 5.67
.Width = [a1].ColumnWidth * 5.67
End With
End If
End Select
End Select
End Sub
Gruss Rainer