Code does not Extract the Images from some URL

Question

I have been using this code which works for some URL but not for all I really do not why. Then I have tried with different available codes online but no success.

Your help will be really appreciated in this regards.

Option Explicit
Dim rng As Range
Dim cell As Range
Dim Filename As String
    
Sub URLPictureInsert()
    Dim theShape As Shape
    Dim xRg As Range
    Dim xCol As Long
    On Error Resume Next
    Application.ScreenUpdating = False
    Set rng = ActiveSheet.Range("A1:A3000")   ' <---- ADJUST THIS
    For Each cell In rng
        Filename = cell
        If InStr(UCase(Filename), "JPG") > 0 Then   ' <--- USES JPG ONLY
            ActiveSheet.Pictures.Insert(Filename).Select
            Set theShape = Selection.ShapeRange.Item(1)
            If theShape Is Nothing Then GoTo isnill
            xCol = cell.Column + 1
            Set xRg = Cells(cell.Row, xCol)
            With theShape
                .LockAspectRatio = msoFalse
                .Width = 20
                .Height = 20
                .Top = xRg.Top + (xRg.Height - .Height) / 2
                .Left = xRg.Left + (xRg.Width - .Width) / 2
            End With
    isnill:
            Set theShape = Nothing
            Range("A2").Select
        End If
    Next
    Application.ScreenUpdating = True

    Debug.Print "Done " & Now

End Sub

URL's

    https://s3-eu-west-1.amazonaws.com/images.linnlive.com/a93f20bbb3640a1a7dc9b9a05bee8540/fc310885-cd82-49cb-bc7a-aabd08531517.jpg
    https://s3-eu-west-1.amazonaws.com/images.linnlive.com/a93f20bbb3640a1a7dc9b9a05bee8540/c6c7a645-8273-40ee-87e5-1dd385111a28.jpg
    https://s3-eu-west-1.amazonaws.com/images.linnlive.com/a93f20bbb3640a1a7dc9b9a05bee8540/cf9f971b-6af6-4894-a2d5-c58681adb466.jpg

Answer 1

Try this code below, it will Debug.Print the URL that fails to insert. Adapt to your need (if any)

Sub URLPictureInsert()
    Dim rng As Range
    Dim cell As Range
    
    Application.ScreenUpdating = False
    With ActiveSheet
        Set rng = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)   ' <---- ADJUST THIS
    End With
    
    
    For Each cell In rng
        If InStr(UCase(cell), "JPG") > 0 Then   '<--- ONLY USES JPG'S
            
            With cell.Offset(0, 1)
                On Error Resume Next
                ActiveSheet.Shapes.AddPicture cell, msoFalse, msoTrue, .Left + (.Width - 10) / 2, .Top + (.Height - 10) / 2, 20, 20
                If Err.Number = 1004 Then Debug.Print "File not found: " & cell
                On Error GoTo 0
            End With
            
        End If
    Next
    
    Application.ScreenUpdating = True
    Debug.Print "Done " & Now
End Sub