Afbeelding downloaden in Excel en linken aan cel

[globe]

Ik gebruik al een tijdje onderstaande code om van een lijst met artikelnummers een afbeelding in te voegen in een excel sheet. Gevonden op het web.

Dit werkt prima maar loop tegen de volgende problemen aan:

- Ik zou graag de afbeeldingen aan een cel willen linken. Als ik nu cellen,rijen of kolommen verwijder blijven de afbeeldingen staan.
- kan ik het script zo maken dat de range automatisch wordt gevuld. Dus bv van cel A1 tot en met de laatst gevulde cel.
- kan ik bij een niet gevonden afbeeldingen een placeholder kunnen zetten? bv een link naar een standaard afbeelding 'Image not found' : https://www.kubus-sports.nl/media/products/notfound.png

Sub URLPictureInsert()
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set Rng = ActiveSheet.Range("A1:A10")
For Each cell In Rng
filenam = "https://www.kubus-sports.nl/media/products/" & cell & "_1.jpg"
ActiveSheet.Pictures.Insert(filenam).Select
Set Pshp = Selection.ShapeRange.Item(1)
If Pshp Is Nothing Then GoTo lab
xCol = cell.Column + 1
Set xRg = Cells(cell.Row, xCol)
With Pshp
.LockAspectRatio = msoFalse
If .Width > xRg.Width Then .Width = xRg.Width * 2 / 3
If .Height > xRg.Height Then .Height = xRg.Height * 2 / 3
.Top = xRg.Top + (xRg.Height - .Height) / 2
.Left = xRg.Left + (xRg.Width - .Width) / 2
End With
lab:
Set Pshp = Nothing
Range("A2").Select
Next
Application.ScreenUpdating = True
End Sub

 

[AHulpje]

.Placement = xlMoveAndSize

Iets gefatsoeneerd (GoTo verwijderd!):

Sub URLPictureInsert()
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set Rng = ActiveSheet.Range("A1:A10")
For Each cell In Rng
filenam = "https://www.kubus-sports.nl/media/products/" & cell & "_1.jpg"
ActiveSheet.Pictures.Insert(filenam).Select
Set Pshp = Selection.ShapeRange.Item(1)
If Not Pshp Is Nothing Then
xCol = cell.Column + 1
Set xRg = Cells(cell.Row, xCol)
With Pshp
.LockAspectRatio = msoFalse
If .Width > xRg.Width Then .Width = xRg.Width * 2 / 3
If .Height > xRg.Height Then .Height = xRg.Height * 2 / 3
.Top = xRg.Top + (xRg.Height - .Height) / 2
.Left = xRg.Left + (xRg.Width - .Width) / 2
.Placement = xlMoveAndSize
End With
End If
Set Pshp = Nothing
'Range("A2").Select
Next
Application.ScreenUpdating = True
End Sub

 

[globe]

top! daar ben ik al een stapje verder mee geholpen.