Save picture as a picture instead of link when using VBA in Excel

Question

I have an Excel file for label template with 6,300 items (each item has a parent ID which matches the picture name that suits the child item).

I found code that will run all the way through without an error (when items are missing for example).
However when share the item it has the pictures saved as a link instead of a picture, and whoever receive that file will have a broken link message.

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

lastrow = Worksheets("sheet2").Range("b1").CurrentRegion.Rows.Count
x = 2
For x = 2 To lastrow
On Error GoTo errhandler:
    Set pastehere = Cells(x, 1)
    pasterow = pastehere.Row
    Cells(pasterow, 1).Select 'This is where picture will be inserted

    pictname = Cells(x, 3) 'This is the picture name

    ActiveSheet.Pictures.Insert("C:\Users\BennyCohen\Pictures\Catalogue pics\" & pictname & ".jpg").Select 'Path to where pictures are stored

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

        .ShapeRange.LockAspectRatio = msoFalse
        .ShapeRange.Height = 140
        .ShapeRange.Width = 80
        .ShapeRange.Rotation = 0#
        .linktofile = msoFalse
        .savewithdocument = msoCTrue
    End With
Next

errhandler:
    Range("A" & x).Value = "Review"
    Resume Next
    
End Sub

Answer 1

linktofile and savewithdocument are not picture properties and the error is masked by the Resume Next in the errhandler, see here. Use Shapes.addPicture().

Sub Picture()

    Const FOLDER = "C:\Users\BennyCohen\Pictures\Catalogue pics\"

    Dim wb As Workbook, ws As Worksheet
    Dim lastrow As Long, r As Long, pictname As String
    Dim n As Long, m As Long

    Set wb = ActiveWorkbook ' or ThisWorkbook
    Set ws = wb.Sheets("Sheet2")
    lastrow = ws.Range("B1").CurrentRegion.Rows.Count
    
    For r = 2 To lastrow

        pictname = FOLDER & ws.Cells(r, 3) & ".jpg" 'This is the picture name
        ' check file exists
        If Len(Dir(pictname)) > 0 Then

            With ws.Shapes.AddPicture(pictname, _
                linktofile:=msoFalse, savewithdocument:=msoTrue, _
                Left:=ws.Cells(r, 1).Left, _
                Top:=ws.Cells(r, 1).Top, _
                Height:=140, Width:=80)
                .LockAspectRatio = msoFalse
                .Rotation = 0#
            End With
            n = n + 1
        
        Else
            ws.Cells(r, "A") = "Review"
            m = m + 1
        End If
    Next
    MsgBox n & " Pictures inserted " & _
           m & " Pictures to review", vbInformation
    
End Sub