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

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple

lrobbo314

Well-known Member
Joined
Jul 14, 2008
Messages
3,134
Office Version
  1. 365
Platform
  1. Windows
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
 

AM_CUL

New Member
Joined
Feb 11, 2021
Messages
5
Office Version
  1. 365
Platform
  1. Windows
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
 

lrobbo314

Well-known Member
Joined
Jul 14, 2008
Messages
3,134
Office Version
  1. 365
Platform
  1. Windows
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
 

AM_CUL

New Member
Joined
Feb 11, 2021
Messages
5
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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.
 

AM_CUL

New Member
Joined
Feb 11, 2021
Messages
5
Office Version
  1. 365
Platform
  1. Windows
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.
 

lrobbo314

Well-known Member
Joined
Jul 14, 2008
Messages
3,134
Office Version
  1. 365
Platform
  1. Windows
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
 
Solution

AM_CUL

New Member
Joined
Feb 11, 2021
Messages
5
Office Version
  1. 365
Platform
  1. Windows
That is amazing thank you Robbo, much appreciated.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,271
Messages
5,635,215
Members
416,847
Latest member
inaramos

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
Top