Using Excel to Pull Images into Cells Based on Text in Adjacent Cell

[Richynero]

Hi guys,

I am building a number of reports for a retail firm. The numbers are straight forward but the creatives want to see images of each item in the report. Each item (T-shirt, jeans, jacket etc) has an item number. For each item number I have a picture of the item saved in a folder.

C:\Users\RichardNero\Documents\Retail Images\

The item numbers will look like this

000151

1004851

1004852

1004853

BKM730MW

BKM731MW

BKM733MW

<tbody>
</tbody>

All the files will be saved as jpegs (.jpg).

What I want to do is loop through my list of item numbers in column A and source the corresponding picture from the folder into the adjacent cell in column B. The picture will need to size to the exact parameters of the cell.

Would be nice to have some sort of error catch that says if it cant find the image from the item number it writes in the cell "Image not found".

I hope that makes sense.

Thanking this awesome community in advance!

Richard

PS: I have spent a while googling this but cant seem to find anything on the subject.

 

[Richynero]

This almost does what I want but cant work out how to size it to the cell.

Sub TestInsertPicture()
    InsertPicture "C:\Users\RichardNero\Documents\Retail Images\1005971.jpg", _
        Range("C7"), True, True
End Sub


Sub InsertPicture(PictureFileName As String, TargetCell As Range, _
    CenterH As Boolean, CenterV As Boolean)
' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
    ' determine positions
    With TargetCell
        t = .Top
        l = .Left
        If CenterH Then
            w = .Offset(0, 1).Left - .Left
            l = l + w / 2 - p.Width / 2
            If l < 1 Then l = 1
        End If
        If CenterV Then
            h = .Offset(1, 0).Top - .Top
            t = t + h / 2 - p.Height / 2
            If t < 1 Then t = 1
        End If
    End With
    ' position picture
    With p
        .Top = t
        .Left = l
    End With
    Set p = Nothing
End Sub

 

[Richynero]

I got it working!

Sub InsertPictureBasedOnCellText()


Dim r As Range
Dim ws As Worksheet
Dim imagePath As String
Dim img As Picture
Dim lrow As Integer
Dim PathAddress As String


lrow = Range("B100000").End(xlUp).Row


For i = 7 To lrow


itemid = Range("B" & i)




PathAddress = "C:\Users\RichardNero\Documents\Retail Images\" & itemid & ".jpg"


Set ws = Worksheets("Sheet1")
Set r = ws.Range("C" & i)
imagePath = PathAddress
Set img = ws.Pictures.Insert(imagePath)


With img
    .ShapeRange.LockAspectRatio = msoFalse
    .Top = r.Top
    .Left = r.Left
    .Width = r.Width
    .Height = r.Height
End With


Next i


End Sub

 

[tonyyy]

Added error checking, and a few tweaks to improve performance...

Sub InsertPictureBasedOnCellText()
Dim r As Range
Dim ws As Worksheet
Dim imagePath As String
Dim img As Picture
Dim lrow As Long, i As Long

Set ws = Worksheets("Sheet1")
lrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
Application.ScreenUpdating = False
For i = 7 To lrow
    imagePath = "C:\Users\RichardNero\Documents\Retail Images\" & Range("B" & i) & ".jpg"
    Set r = ws.Range("C" & i)
    On Error GoTo errHandler:
    Set img = ws.Pictures.Insert(imagePath)
    With img
        .ShapeRange.LockAspectRatio = msoFalse
        .Top = r.Top
        .Left = r.Left
        .Width = r.Width
        .Height = r.Height
    End With
errHandler:
    If Err.Description = "Unable to get the Insert property of the Pictures class" Then _
        r.Value = "Image not found"
    On Error GoTo -1
Next i
Application.ScreenUpdating = True
End Sub

Happy Holidays!

tonyyy