folgende Herausforderungen sind für mich alleine nicht zu bewältigen.
Ich habe eine Maske mit zwei ComboBoxen und beim jeweiligen wählen der Combobox wird jeweils ein Bild in jeweiligen Zellen eingefügt. Das hab ich soweit geschafft, aber das Problem ist wenn ich ein anderes Bild wähle löscht er das vorhandene Bild nicht.
Zudem möchte ich auch, dass man das gewählte Bild auch in der Maske sieht.
Damit ihr genau wisst was ich meine hab ich eine Beispieldatei angehängt.
Dim shpPicture As Shape
Application.ScreenUpdating = False
For Each shpPicture In ActiveSheet.Shapes
If shpPicture.TopLeftCell.Address(0, 0) = "A6" Then shpPicture.Delete
Next shpPicture
'Sheets("Tabelle1").Range("A6").ClearContents
'Schleife um alle Bilder im Blatt "Tabelle1" zu löschen
' Worksheets("Tabelle1").Range("A6").Delete
'Bild dessen Namen in Zelle A1 steht kopieren...
Sheets("Tabelle2").Shapes(Sheets("Tabelle1").Range("A1")).Copy
'...und in Zelle A6 einfügen
Sheets("Tabelle1").Range("A6").PasteSpecial Paste:=xlPasteValues
'Setenverhältnis der Grafik ausschalten und Größe verändern
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100 'Bildhöhe
.ShapeRange.Width = 200 'Bildbreite
End With
Application.ScreenUpdating = True
Dim shpPicture As Shape
Application.ScreenUpdating = False
For Each shpPicture In ActiveSheet.Shapes
If shpPicture.TopLeftCell.Address(0, 0) = "E6" Then shpPicture.Delete
Next shpPicture
'Sheets("Tabelle1").Range("E6").ClearContents
'Schleife um alle Formeln im Blatt "Tabelle1" zu löschen
'Worksheets("Tabelle1").Range("E6").Delete
'Bild dessen Namen in Zelle E1 steht kopieren...
Sheets("Tabelle2").Shapes(Sheets("Tabelle1").Range("E1")).Copy
'...und in Zelle E6 einfügen
Sheets("Tabelle1").Range("E6").PasteSpecial Paste:=xlPasteValues
'Setenverhältnis der Grafik ausschalten und Größe verändern
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 50 'Bildhöhe
.ShapeRange.Width = 100 'Bildbreite
End With
Application.ScreenUpdating = True
For Each shpPicture In ActiveSheet.Shapes
If Not Intersect(Range(shpPicture.TopLeftCell.Address), Cells(5, 1).Resize(3)) Is Nothing Then shpPicture.Delete
Next shpPicture
'Sheets("Tabelle1").Range("A6").ClearContents
'Schleife um alle Bilder im Blatt "Tabelle1" zu löschen
' Worksheets("Tabelle1").Range("A6").Delete
'Bild dessen Namen in Zelle A1 steht kopieren...
Sheets("Tabelle2").Shapes(Sheets("Tabelle1").Range("A1")).Copy
'...und in Zelle A6 einfügen
Sheets("Tabelle1").Range("A6").PasteSpecial Paste:=xlPasteValues
'Setenverhältnis der Grafik ausschalten und Größe verändern
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100 'Bildhöhe
.ShapeRange.Width = 200 'Bildbreite
End With
Application.ScreenUpdating = True
End Sub
Private Sub cboFormel_Change()
Dim shpPicture As Shape
For Each shpPicture In ActiveSheet.Shapes
If Not Intersect(Range(shpPicture.TopLeftCell.Address), Cells(5, 4).Resize(3, 2)) Is Nothing Then shpPicture.Delete
Next shpPicture
'Sheets("Tabelle1").Range("E6").ClearContents
'Schleife um alle Formeln im Blatt "Tabelle1" zu löschen
'Worksheets("Tabelle1").Range("E6").Delete
'Bild dessen Namen in Zelle E1 steht kopieren...
Sheets("Tabelle2").Shapes(Sheets("Tabelle1").Range("E1")).Copy
'...und in Zelle E6 einfügen
Sheets("Tabelle1").Range("E6").PasteSpecial Paste:=xlPasteValues
'Setenverhältnis der Grafik ausschalten und Größe verändern
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 50 'Bildhöhe
.ShapeRange.Width = 100 'Bildbreite
End With
Application.ScreenUpdating = True
End Sub
Gruß Stefan Win 10 / Office 2016
Folgende(r) 1 Nutzer sagt Danke an Steffl für diesen Beitrag:1 Nutzer sagt Danke an Steffl für diesen Beitrag 28 • Joe
19.10.2015, 09:54 (Dieser Beitrag wurde zuletzt bearbeitet: 19.10.2015, 09:56 von Kuwer.)
(19.10.2015, 08:31)Joe schrieb: Eine Frage was bedeutet Resize in dem Zusammenhang genau hab den Befehl nachgooglet, aber der Sinn erschließt mir noch nicht ganz.
Hallo Joe,
da brauchst Du nicht googlen, sondern nur den Cursor darauf setzen und F1 drücken!