Externe afbeelding in Excel plakken via Macro

[conad]

Hi,

In Excel heb ik een opsomming van producten waarbij er steeds een unieke code per product aanwezig is
Ik heb een macro geschreven waardoor afbeeldingen die zich in een bepaalde map op mijn pc bevinden, automatisch worden toegevoegd bij het juiste product op basis van die unieke code. Werkt perfect (alleen duurt het wat lang).

Probleem is echter dat wanneer ik de Excel opsla en verstuur naar bijvoorbeeld klanten, de afbeeldingen niet meer beschikbaar zijn. Dit aangezien de koppeling naar mijn schuiven uiteraard weg is dan.

Ik zoek dus naar een manier waarbij die afbeeldingen echt geplakt worden in Excel ipv dat het om een verwijzing gaat zoals nu het geval is.
Iemand een idee hoe ik dat kan aanpakken.

De macro die ik gebruik is de volgende:

Sub Picture()
Dim pictname As String
Dim group As String
Dim pastehere As Range
Dim pasterow As Long
Dim x As Long
Dim lastrow As Long

On Error Resume Next

lastrow = Worksheets("Prijslijst").Range("H1").CurrentRegion.Rows.Count
x = 3
For x = 3 To lastrow
Set pastehere = Cells(x, 1)
pasterow = pastehere.Row
Cells(pasterow, 1).Select 'This is where picture will be inserted


pictname = Cells(x, 4) 'This is the picture name
ActiveSheet.Pictures.Insert("C:\Users\yst\Desktop\Images" & pictname & ".png").Select 'Path to where pictures are stored

With Selection

.Left = Cells(pasterow, 1).Left
.Top = Cells(pasterow, 1).Top

.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 70#
.ShapeRange.Width = 70#
.ShapeRange.Rotation = 0#
End With

 

[edmoor]

Gebruik dan de Shapes.AddPicture methode in plaats van Pictures.Insert:
https://docs.microsoft.com/en-us/office/vba/api/excel.shapes.addpicture

Voor de snelheid kan je uiteraard ook Application.ScreenUpdating = False gebruiken.
Hou er ook rekening mee dat je document veel groter zal worden met al die plaatjes er in.

 

[VenA]

Code graag tussen codetags voor de leesbaarheid. De code lijkt mij nodeloos ingewikkeld.

Sub VenA()
  With Sheets("Prijstlijst")
    For j = 3 To .Cells(Rows.Count, 8).End(xlUp).Row
      .Shapes.AddPicture Cells(j, 4).Value, True, True, .Cells(j, 1).Left, .Cells(j, 1).Top, 70, 70
    Next j
  End With
End Sub

 

[conad]

Bedankt!

Bedankt!
Werkt perfect.