Putting images onto an excel sheet via URL links - vba

Question

My sheet has three columns, "A" = Images, "B" = Image Names, and "C" = URL Links, with Rows 1 and 2 being used as headers and rows 3 to 1002 for user input. The Current working code will search for the image names in Column "B" in the folder you select, and inserts them into Column "A". This macro runs off of a commandbutton I have placed on a userform I have created.
Working code is as follows (this is a edited version of the accepted answer here):
Private Sub Add_Images_Click()
Const EXIT_TEXT As String = ""
Const NO_PICTURE_FOUND As String = "No picture found"
Dim picName As String
Dim picFullName As String
Dim rowIndex As Long
Dim lastRow As Long
Dim selectedFolder As String
Dim data() As Variant
Dim wks As Worksheet
Dim Cell As Range
Dim pic As Picture
On Error GoTo ErrorHandler
selectedFolder = GetFolder
If Len(selectedFolder) = 0 Then GoTo ExitRoutine
Application.ScreenUpdating = False
Set wks = ActiveSheet
lastRow = wks.Cells(2, "B").End(xlDown).Row
data = wks.Range(wks.Cells(3, "B"), wks.Cells(lastRow, "B")).Value2
For rowIndex = 3 To UBound(data, 1)
If StrComp(data(rowIndex, 1), EXIT_TEXT, vbTextCompare) = 0 Then GoTo ExitRoutine
picName = data(rowIndex, 1)
picFullName = selectedFolder & picName
If Len(Dir(picFullName)) > 0 Then
Set Cell = wks.Cells(rowIndex, "A")
Set pic = wks.Pictures.Insert(picFullName)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = Cell.Height
.Width = Cell.Width
.Top = Cell.Top
.Left = Cell.Left
.Placement = xlMoveAndSize
End With
Else
wks.Cells(rowIndex, "A").Value = NO_PICTURE_FOUND
End If
Next rowIndex
ExitRoutine:
Set wks = Nothing
Set pic = Nothing
Application.ScreenUpdating = True
UserForm.Hide
Exit Sub
ErrorHandler:
MsgBox Prompt:="Unable to find photo", _
Title:="An error occured", _
Buttons:=vbExclamation
Resume ExitRoutine
End Sub
Private Function GetFolder() As String
Dim selectedFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Select the folder containing the Image/PDF files."
.Show
If .SelectedItems.count > 0 Then
selectedFolder = .SelectedItems(1)
If Right$(selectedFolder, 1) <> Application.PathSeparator Then _
selectedFolder = selectedFolder & Application.PathSeparator
End If
End With
GetFolder = selectedFolder
End Function
I'm looking for a way to edit this macro so that it would be able to use the URL links for the images in Column "C" and find and insert the images into Column "A" that way. I found a working code (can't remember where, or I'd link it) that I tried to adapt with my current code to achieve the desired results.
The sample code I found online:
Sub Images_Via_URL()
Dim url_column As Range
Dim image_column As Range
Set url_column = Worksheets(1).UsedRange.Columns("A")
Set image_column = Worksheets(1).UsedRange.Columns("B")
Dim i As Long
For i = 2 To url_column.Cells.Count
With image_column.Worksheet.Pictures.Insert(url_column.Cells(i).Value)
.Left = image_column.Cells(i).Left
.Top = image_column.Cells(i).Top
.Height = 100
.Width = 100
End With
Next
End Sub
The following code is my failed attempt to edit it myself. It worked once for a list of 7 URL links, then I deleted one of the links in the middle to see if it would handle the blank cell correctly, and now it flat out wont work. It goes into the "ExitRoutine" every time.
Not Working Code:
Option Explicit
Private Sub URL_Images_Click()
Const EXIT_TEXT As String = ""
Const NO_PICTURE_FOUND As String = "No picture found"
Dim picURL As String
Dim rowIndex As Long
Dim lastRow As Long
Dim data() As Variant
Dim wks As Worksheet
Dim Cell As Range
Dim pic As Picture
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Set wks = ActiveSheet
lastRow = wks.Cells(2, "B").End(xlDown).Row
data = wks.Range(wks.Cells(3, "C"), wks.Cells(lastRow, "C")).Value2
For rowIndex = 3 To UBound(data, 1)
**If StrComp(data(rowIndex, 1), EXIT_TEXT, vbTextCompare) = 0 Then GoTo ExitRoutine**
picURL = data(rowIndex, 1)
If Len(picURL) > 0 Then
Set Cell = wks.Cells(rowIndex, "A")
Set pic = wks.Pictures.Insert(picURL)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = Cell.Height
.Width = Cell.Width
.Top = Cell.Top
.Left = Cell.Left
.Placement = xlMoveAndSize
End With
Else
wks.Cells(rowIndex, "A").Value = NO_PICTURE_FOUND
End If
Next rowIndex
ExitRoutine:
Set wks = Nothing
Set pic = Nothing
Application.ScreenUpdating = True
UserForm.Hide
Exit Sub
ErrorHandler:
MsgBox Prompt:="Unable to find photo", _
Title:="An error occured", _
Buttons:=vbExclamation
Resume ExitRoutine
End Sub
I've bolded the line that is forcing it to the "ExitRoutine". I'm not sure how exactly that line works as I am not the one who originally wrote it. Any help would be great!

Answer 1

lastRow = wks.Cells(2, "B").End(xlDown).Row
data = wks.Range(wks.Cells(3, "C"), wks.Cells(lastRow, "C")).Value2
For rowIndex = 3 To UBound(data, 1)
'....
If you start at rowIndex = 3 then you're skipping the first two rows of your input data: a 2-D array from a range always has lower bounds of 1 for both dimensions, regardless of the location of the range.
In this case data(1,1) will correspond to C3, whereas data(3,1) is C5