Pulling images from a list of codes

AM_CUL

New Member
Joined
Feb 11, 2021
Messages
5
Office Version
  1. 365
Platform
  1. Windows
Hi guys, hope everyone is keeping well.

I was wondering if I could get some help creating a macro which will insert images for me from a list.

I'm on Excel 365 for business. I have a list of unique codes descending in column A (100 row max) and then in column B I would like an image to be added which corresponds to that code, ideally to fit in a 100x25 box. The images are all located in a single folder and titled the same as their unique code. Images are also all jpegs.

Could anyone please offer any advice on how best to approach this? I'd be extremely grateful as currently I'm doing it manually which is very time consuming when working through multiple lists each day.

Thanks.

1613082645591.png
 

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
You'll need to change the path to where your pictures are, but this should work.

VBA Code:
Sub getPICS()
Dim r As Range:         Set r = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
Dim fPath As String:    fPath = Join(Array(Environ("userprofile"), "Pictures", ""), "\")
Dim xlPic As Shape
Dim cel As Range
Dim oCel As Range

For Each cel In r
    Set oCel = cel.Offset(, 1)
    Set xlPic = ActiveSheet.Shapes.AddPicture(fPath & cel.Value2 & ".jpg", msoFalse, msoCTrue, oCel.Left, oCel.Top, oCel.Width, oCel.Height)
    xlPic.Placement = xlMoveAndSize
    xlPic.LockAspectRatio = msoCTrue
Next cel

End Sub
 
Upvote 0
Hi Robbo

Thanks so much for this. Sorry but where exactly do I add in the path? I've tried inserting at the top, over pictures but that didn't work.

Say for example my path is this: C:\Users\AM\Company\Private - AM\Images

Thanks
Alex
 
Upvote 0
This should do it.

VBA Code:
Sub getPICS()
Dim r As Range:         Set r = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
Dim fPath As String:    fPath = "C:\Users\AM\Company\Private - AM\Images\"
Dim xlPic As Shape
Dim cel As Range
Dim oCel As Range

For Each cel In r
    Set oCel = cel.Offset(, 1)
    Set xlPic = ActiveSheet.Shapes.AddPicture(fPath & cel.Value2 & ".jpg", msoFalse, msoCTrue, oCel.Left, oCel.Top, oCel.Width, oCel.Height)
    xlPic.Placement = xlMoveAndSize
    xlPic.LockAspectRatio = msoCTrue
Next cel

End Sub
 
Upvote 0
Robbo, you're absolute genius - thank so much.

On a side note, I know I could edit this to pull png images but is there an input which would pull both png & jpeg if there was a mix of file types?

Thanks again.
 
Upvote 0
Sorry Robbo, another question. Is it possible to edit it such that, if it encounters an image which is not there it will skip it and continue down the list? Currently it runs into a debug error message?

Thanks.
 
Upvote 0
How about this?

VBA Code:
Sub getPICS()
Dim r As Range:         Set r = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
Dim fPath As String:    fPath = "C:\Users\AM\Company\Private - AM\Images\"
Dim xlPic As Shape
Dim cel As Range
Dim oCel As Range

For Each cel In r
    If Len(Dir(fPath & cel.Value2 & ".jpg")) > 0 Then
        Set oCel = cel.Offset(, 1)
        Set xlPic = ActiveSheet.Shapes.AddPicture(fPath & cel.Value2 & ".jpg", msoFalse, msoCTrue, oCel.Left, oCel.Top, oCel.Width, oCel.Height)
        xlPic.Placement = xlMoveAndSize
        xlPic.LockAspectRatio = msoCTrue
    ElseIf Len(Dir(fPath & cel.Value2 & ".png")) > 0 Then
        Set oCel = cel.Offset(, 1)
        Set xlPic = ActiveSheet.Shapes.AddPicture(fPath & cel.Value2 & ".png", msoFalse, msoCTrue, oCel.Left, oCel.Top, oCel.Width, oCel.Height)
        xlPic.Placement = xlMoveAndSize
        xlPic.LockAspectRatio = msoCTrue
    End If
Next cel

End Sub
 
Upvote 0
Solution

Forum statistics

Threads
1,213,482
Messages
6,113,916
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top