Insert pictures into excel from a folder

[John Steel]

Greetings everyone,

First off let me say that I have searched for a day on this site and others trying to find an solution to my problem. I'm trying to insert five pictures into excel by looking them up via five reference cells containing the pictures' names on the worksheet.

Some of the things I'd like to accomplish with the macro:

1. The macro would delete any existing pictures in the target areas.
2. The pictures would maintain their aspect ratio and resize to the exisiting row height and be centered in the target range (four cells wide)
3. If one of the references for the picture name is blank - delete any existing picture and skip attempting to import anything for that item

Here are my reference and target cells

Reference Cell (Name of picture file)	Target Range for importing picture
A1	C3:F3
A40	C42:F42
A79	C81:F81
A118	C120:F120
A157	C159:F159

<tbody>
</tbody>

My picture files are all .jpg and located at "C:\Users\jstee\Dropbox\Comp photos" The worksheet is called "Comp Sheets" Hopefully I've not omitted anything required in my explanation.

The code I've tried to adapt from is for just one picture at this time as I want to get that to work before adding the loop necessary to do the other four pictures - although this I'll need help with as well I imagine. Here's what I have so far. I haven't gotten it to import anything so my troubleshooting is still in its infancy.

Sub Picture()
Dim picname As String

Range("C3:F3").Select 'This is where picture will be inserted

picname = Range("A1") 'This is the picture name

On Error Resume Next
'delete previous pic
ActiveSheet.Pictures("Comp Sheets").Delete
Err.Clear
Err.Number = 0
On Error GoTo 0

If (Dir("C:\Users\jstee\Dropbox\Comp photos" & picname & ".jpg") = vbNullString) Then Exit Sub

ActiveSheet.Pictures.Insert("C:\Users\jstee\Dropbox\Comp photos" & picname & ".jpg").Select 'Path to where pictures are stored
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
.Name = "Comp Sheets"
.Left = Range("C3:F3").Left
.Top = Range("C3:F3").Top
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = 95#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If (Intersect(Target, Range("A1")) Is Nothing) Then
Exit Sub
End If

Application.EnableEvents = False
Call Picture
Application.EnableEvents = True
End Sub​

Any help would be greatly appreciated.

Thank you

 

[John Steel]

Yeah - something simple. I was trying to alter the code so it would only affect C:F on the sheet but couldn't get it to work.

Thanks again Perpa.

Here's my finished code for my application for anyone else following.

Sub Insert_Comp_Pictures()
    Dim Folderpath, fls, strCompFilePath As String
    Dim counter, counter2 As Long
    Dim sh As Shape
    Application.ScreenUpdating = False
  
    Sheets("Comp Sheets").Activate           'Change the sheet name to the sheet name where you want your pictures to go
        For Each sh In ActiveSheet.Shapes
           If sh.Type = msoPicture Then sh.Delete
        Next sh
    Range("C3:F3").ColumnWidth = 22    'Adjust to fit your pictures
    Folderpath = "C:\Users\jstee\Dropbox\Comp_photos\"    'Change the folderpath if different
            For counter = 1 To 157 Step 39
                fls = Sheets("Comp Sheets").Range("A" & counter).Value
                If fls = "" Then GoTo SKIP_PIC
                strCompFilePath = Folderpath & fls
                Sheets("Comp Sheets").Range("C" & counter).Offset(2, 0).RowHeight = 230          'Adjust to fit your pictures
                Sheets("Comp Sheets").Range("C" & counter).Offset(2, 0).Activate
                counter2 = counter + 2    'Moves the row where the picture will be placed from 1 to 3 for C3:F3, 40 to 42 for C42:F42, and so on
                Call insert(strCompFilePath, counter2)
                Sheets("Comp Sheets").Activate
SKIP_PIC:
            Next
Application.ScreenUpdating = True
End Sub


Function insert(PicPath, counter2)
   Set objPicture = ActiveSheet.Pictures.insert(PicPath)
    With objPicture
        With .ShapeRange
            .LockAspectRatio = msoTrue     'Height and Width cannot BOTH be set if the Aspect Ratio is LOCKED
            '.Width = 50      'Adjust to change the WIDTH of your pictures - currently commented out
            .Height = 230   'Adjust to change the HEIGHT of your pictures
        End With
       'This next 'With' centers the picture in the 4 cells
        With ActiveSheet.Range("C" & counter2 & ":F" & counter2)
              objPicture.Left = .Left + .Width \ 2 - objPicture.Width \ 2
        End With
 
        .Top = ActiveSheet.Range("C" & counter2 & ":F" & counter2).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function