Guten Tag liebe Community,
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.
Schöne Grüße Joe
Hallo Joe,
mal nur der Teil mit dem Löschen (das mit der Maske habe ich überlesen :20: )
Code:
Private Sub cboAuto_Change()
Worksheets("Tabelle1").Range("A1") = Me.cboAuto.Value
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
End Sub
Private Sub cboFormel_Change()
Worksheets("Tabelle1").Range("E1") = Me.cboFormel.Value
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
End Sub
Moin Stefan,
der Code funktioniert nicht
.
Oder gibt es da zu meinem Problem eine komplett andere vorangehensweise und wenn ja welche?
Gruß Joe
Hallo Joe,
befinden sich die Bilder jeweils in A6 bzw. E6? Teste mal, indem Du das Bild markierst und im Direkfenster
Code:
?selection.topleftcell.address
einträgst und auf Return drückst. Was wird dir zurückgegeben?
Hallo Joe,
ich habe den Code nochmal umgearbeitet.
Code:
Private Sub cboAuto_Change()
Dim shpPicture As Shape
Worksheets("Tabelle1").Range("A1") = Me.cboAuto.Value
Application.ScreenUpdating = False
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
Worksheets("Tabelle1").Range("E1") = Me.cboFormel.Value
Application.ScreenUpdating = False
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
Hey Stafan,
ich hab dein Code ausprobiert und der funktioniert super, DANKE!
Eine Frage was bedeutet Resize in dem Zusammenhang genau hab den Befehl nachgooglet, aber der Sinn erschließt mir noch nicht ganz.
Gruß Joe
Hey,
ich versuche immernoch ein Bild in der Userform anzuzeigen, aber irgendwie klappt es bei mir nicht.
Code:
With UserForm1
.Image1.Picture = LoadPicture(Worksheets("Tabelle1").Cells(5, 1))
.Image1.PictureSizeMode = fmPictureSizeModeZoom
End With
Was mache ich falsch?
Gruß Joe
(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!
Gruß Uwe