insert picture from folder based on names within cell.

[tjhadders]

Please Help! After hours of searching the internet, I'm having issues importing images from a folder into a worksheet using VBA.

The folder path which contains images is = R:\Database Photos

All images are JPEG files and different sizes. The corresponding lookup names will match the file name within the folder excluding the file extension.

The worksheet name is "sales output".

In column "B" I have 10 cells from which i need to source a picture. These cells are non-contiguous and range from "B6" to "B26". For Example: B6, B8, B10, B12, B15, B17, B19, B22, B24, B26.

I want the images to auto format and resize then insert within the same row as the corresponding lookup cell in column "B" but within column "D". I would like the images to be 70 x 70


Thanks in advance!

 

[Yongle]

Welcome to the forum @tjhadders

Give this a try

Sub InsertPictures()
    Const fPath = "R:\Database Photos"
    Dim a As Variant, cel As Range, picPath As String
    
    For Each a In Array("B6", "B8", "B10", "B12", "B15", "B17", "B19", "B22", "B24", "B26")
        Set cel = Sheets("Sales Output").Range(a)
        picPath = fPath & "\" & cel.Value & ".jpg"
        
        If Not Dir(picPath, vbDirectory) = vbNullString Then
            With cel.Parent.Pictures.Insert(picPath)
                With .ShapeRange
                    .LockAspectRatio = msoFalse
                    .Width = 70
                    .Height = 70
                End With
                .Left = cel.Offset(, 2).Left
                .Top = cel.Offset(, 2).Top
            End With
        End If
    Next a
End Sub

 

[tjhadders]

Thanks Yongle - that worked a treat!

The macro runs and the pictures insert however i get a debug error, specifically in the "picPath = fPath & "" & cel.Value & ".jpg" code.

Is there a way to fix this?

 

[Yongle]

My code in post#2 has a backslash in it - but your code in post#3 does not

picPath = fPath & "\" & cel.Value & ".jpg"

 

[tjhadders]

Sorry that was copy paste error on my behalf in post#3.

Its still has a debug error with the backslash (picPath = fPath & "\" & cel.Value & ".jpg"

 

[tjhadders]

Sorry to be a PITA but ive had to adjust my output tables to accommodate a few other things, which means the code cant be static (i.e. cant look up values in the specified cells B6, B8, B10 etc.) as the values in the cell will be moving depending on circumstances, but will be within a range in Column B.

Is there a way to amend the code to search a range of values in column "B" and have the images resize then insert within the same row as the corresponding lookup cell in column "D"

Thanks in advance!

 

[Yongle]

This minor modification should give you what you want

Sub InsertPictures()
    Const fPath = "c:\TestArea\jpg"
    Dim cel As Range, picPath As String
    
    For Each cel In Range("B2", Range("B" & Rows.Count).End(xlUp))
        On Error Resume Next
        picPath = fPath & "\" & cel.Value & ".jpg"
        If Not Dir(picPath, vbDirectory) = vbNullString Then
            With cel.Parent.Pictures.Insert(picPath)
                With .ShapeRange
                    .LockAspectRatio = msoFalse
                    .Width = 70
                    .Height = 70
                End With
                .Left = cel.Offset(, 2).Left
                .Top = cel.Offset(, 2).Top
            End With
        End If
    Next cel
End Sub

 

[Yongle]

Are you wanting to run the code again when some images have already been added to the sheet?
- above code would insert images on top of prior inserted images every time the code is run

To avoid that, then all images already in the worksheet could be deleted first before inserting all images determined by values in column B

Sub InsertPictures()
    Const fPath = "c:\TestArea\jpg"
    Dim cel As Range, picPath As String, shp As Shape
'delete prior images[COLOR=#008080]
    For Each shp In ActiveSheet.Shapes
        If Left(shp.Name, 7) = "Picture" Then shp.Delete
    Next shp[/COLOR]
'insert images
    For Each cel In Range("B2", Range("B" & Rows.Count).End(xlUp))
        On Error Resume Next
        picPath = fPath & "\" & cel.Value & ".jpg"
        If Not Dir(picPath, vbDirectory) = vbNullString Then
            With cel.Parent.Pictures.Insert(picPath)
                With .ShapeRange
                    .LockAspectRatio = msoFalse
                    .Width = 70
                    .Height = 70
                End With
                .Left = cel.Offset(, 2).Left
                .Top = cel.Offset(, 2).Top
            End With
        End If
    Next cel
End Sub

If there are other images in the worksheet that should be retained, simply rename those so that their names do not begin with "Picture"