Afbeelding toevoegen op basis van voorwaarde

[Peer44]

Hallo,

ik probeer om automatisch een afbeelding toe te voegen aan een werkblad.
als het benoemd bereik "aantalAuto" niet 0 is, wil ik in het bereik "auto" een afbeelding plaatsen van een auto.
hetzelfde geldt voor fiets.

Heb een voorbeeldbestand toegevoegd.

met onderstaande code werkt het (nog) niet.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)


If Range("aantalAuto") = Not 0 Then
ActiveSheet.Range("auto").Picture.Insert ("C:\.....\auto.jpg")
'de afbeelding moet komen op de locatie E14'

End If

If Range("aantalFiets") = Not 0 Then
ActiveSheet.Range("fiets").Picture.Insert ("C\...............fiets.jpg")
'de afbeelding moet komen op de locatie d14'

End If

End Sub

Hopelijk kunnen julle me verder helpen....

 

[Warme bakkertje]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sShape As Shape
If Range("aantalAuto") <> 0 Then
    Set sShape = ActiveSheet.Shapes.AddPicture("C\...............auto.jpg", _
                        msoFalse, msoCTrue, Range("auto").Left + 2, Range("auto").Top + 2, 275, 178)
End If
If Range("aantalFiets") <> 0 Then
    Set sShape = ActiveSheet.Shapes.AddPicture("C\...............fiets.jpg", _
                        msoFalse, msoCTrue, Range("fiets").Left + 2, Range("fiets").Top + 2, 213, 178)
End If
End Sub

 

[Peer44]

Krijg met onderstaande code de volgende melding:

Compileerfout: Syntaxisfout

in dit geval is deze regel geselecteerd:

Set sShape = ActiveSheet.Shapes.AddPicture("C:\pepernoot.jpg",

volledige code:

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
Dim sShape As Shape
If Range("aantalAuto") <> 0 Then
    Set sShape = ActiveSheet.Shapes.AddPicture("C:\sinterklaas.jpg", _
                        msoFalse, msoCTrue, Range("auto").Left + 2, Range("auto").Top + 2, 275, 178)
End If
If Range("aantalFiets") <> 0 Then
    Set sShape = ActiveSheet.Shapes.AddPicture("C:\pepernoot.jpg",
                        msoFalse, msoCTrue, Range("fiets").Left + 2, Range("fiets").Top + 2, 213, 178)
End If
End Sub

 

[Peer44]

Rudi alvast bedankt!

met onderstaande code werkt het. Maar wil nog een kleine uitbreiding toevoegen....

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
Dim sShape As Shape
If Range("aantalAuto") <> 0 Then
    Set sShape = ActiveSheet.Shapes.AddPicture("C:\auto.jpg", _
                        msoFalse, msoCTrue, Range("auto").Left + 2, Range("auto").Top + 2, 275, 178)
End If
If Range("aantalFiets") <> 0 Then
    Set sShape = ActiveSheet.Shapes.AddPicture("C:\fiets.jpg", _
                        msoFalse, msoCTrue, Range("fiets").Left + 2, Range("fiets").Top + 2, 213, 178)
End If
End Sub

Wanneer echter de range van fiets of auto weer terug op 0 gezet wordt blijft de afbeelding staan, hoe kan ik ervoor zorgen dat deze dan ook weer verdwijnt?

 

[Warme bakkertje]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sShape As Shape
On Error Resume Next
If Range("aantalAuto") <> 0 Then
    Set sShape = ActiveSheet.Shapes.AddPicture("C:\auto.jpg", _
                        msoFalse, msoCTrue, Range("auto").Left + 2, Range("auto").Top + 2, 275, 178)
    sShape.Name = "afbauto"
ElseIf Range("aantalAuto").Value = 0 Then
    ActiveSheet.Shapes("afbauto").Delete
End If
If Range("aantalFiets") <> 0 Then
    Set sShape = ActiveSheet.Shapes.AddPicture("C:\fiets.jpg", _
                        msoFalse, msoCTrue, Range("fiets").Left + 2, Range("fiets").Top + 2, 213, 178)
    sShape.Name = "afbfiets"
ElseIf Range("aantalFiets").Value = 0 Then
    ActiveSheet.Shapes("afbfiets").Delete
End If
End Sub

 

[Peer44]

Rudi bedankt,

werkt perfect!