Using URLs to Insert Pictures [VBA]

[DataBlake]

Hello all,

So KuTools has this code which i've adapted for my needs, and when i run through the code with F8 I'm unsure of where it messes up.
I have 3 columns of image url's (some cells are blank) I set the range to the first column with images which is column B
I want it to insert the images to the column to the right of the range (column C)

Sub URLPictureInsert()
'Updateby Extendoffice 20161116
    Dim Pshp As Shape
    Dim xRg As Range
    Dim xCol As Long
    Dim lastrow As Long
    
    lastrow = Range("A" & Rows.Count).End(xlUp).Row
    
    On Error Resume Next
    Application.ScreenUpdating = False
    Set Rng = ActiveSheet.Range("B:B" & lastrow)
    For Each cell In Rng
        filenam = cell
        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
            .Width = 100
           .Height = 100
            .Top = xRg.Top + (xRg.Height - .Height) / 2
            .Left = xRg.Left + (xRg.Width - .Width) / 2
        End With
lab:
    Set Pshp = Nothing
    Range("B2").Select
    Next
    Application.ScreenUpdating = True
End Sub

can anyone point out where this isn't working as intended?
It runs but does nothing/inserts nothing

 

[DataBlake]

        If Pshp Is Nothing Then GoTo lab

so this line seems to be taking me out of the loop
so the macro is assuming that there are no blank cells.

 

[DataBlake]

okay so after poking around i've changed the code to

Sub URLPictureInsert()
'Updateby Extendoffice 20161116
    Dim Pshp As Shape
    Dim i As Long
    Dim lastRow As Long
    Dim urlRng As Range
    Dim trgtRng As Range
    
    
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow

   Set urlRng = Range("B" & i)
   Set trgtRng = Range("C" & i)
    
        filenam = urlRng
        ActiveSheet.Pictures.Insert(filenam).Select
        Set Pshp = Selection.ShapeRange.Item(1)
        If Pshp Is Nothing Then trgtRng = ""
        
    With Pshp
            .LockAspectRatio = msoFalse
            .Width = 15
            .Height = 15
            .Top = trgtRng.Top
            .Left = trgtRng.Left
    End With

        
    Next i
End Sub

this works perfectly until it runs into a blank cell

 

[DataBlake]

here is my final version where it skips blank cells in the url column
If you need to put an image based on a url into your worksheet just change urlRng column for the URL column and the trgtRng column for where you want the image to appear in.
As well changing the width/height to suit your needs

Sub URLPictureInsert()
    Dim Pshp As Shape
    Dim i As Long
    Dim lastRow As Long
    Dim urlRng As Range
    Dim trgtRng As Range
    
    
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow

   Set urlRng = Range("B" & i)
   Set trgtRng = Range("C" & i)
   
If urlRng = "" Then GoTo lastline
    
        filenam = urlRng
        ActiveSheet.Pictures.Insert(filenam).Select
        Set Pshp = Selection.ShapeRange.Item(1)
        If Pshp Is Nothing Then trgtRng = ""
        
    With Pshp
            .LockAspectRatio = msoFalse
            .Width = 15
            .Height = 15
            .Top = trgtRng.Top
            .Left = trgtRng.Left
    End With

lastline:
    Next i
End Sub

 

[Dan_W]

As an alternative:

Sub InsertWebPicture(URL As String, target As Range, Optional picWidth As Long = -1, Optional picHeight As Long = -1)
    target.Parent.Shapes.AddPicture URL, True, True, target.Left, target.Top, picWidth, picHeight
End Sub

This approach uses the pictures default width and height, unless you intentionally change it.