Insert picture corresponding to cell value using excel macro

Question

I'm using the macro below to insert the picture corresponding to the value in Cell P2 into cell Q2.

This works for the one cell selected (P2 in this case).

I want to create a loop to do the same action for the rows in Column P range (P2:P500) that are not blank.

Sub Picture()

 Range("Q2").Select 
 Dim picname As String

 picname = "C:\Users\kisnahr\Pictures\Test\" & Range("P2") & ".bmp" 'Link to the picture
 ActiveSheet.Pictures.Insert(picname).Select

 With Selection
 .Left = Range("Q2").Left
 .Top = Range("Q2").Top
 .ShapeRange.LockAspectRatio = msoFalse
 .ShapeRange.Height = 80#
 .ShapeRange.Width = 80#
 .ShapeRange.Rotation = 0#
 End With

 Range("Q10").Select
 Application.ScreenUpdating = True

 Exit Sub

 ErrNoPhoto:
 MsgBox "Unable to Find Photo" 'Shows message box if picture not found
 Exit Sub
 Range("P20").Select

 End Sub

score 0 · Answer 1 · answered Sep 28 '15 at 10:15

Try something along these lines. This is a very rough and ready solution, so you'll need to adapt it to your own requirements. Here I've put the image path in column B and is fired off from a CommandButton4 click. Not sure how you define your cell Left and Cell Top though?

Private Sub CommandButton4_Click()
 Dim MyRange As String
 Dim picname As String
 Dim mySelectRange As String
 Dim rcell As Range
 Dim IntInstr As Integer
 Dim Mypath As String

 Mypath = "z:\My Pictures"
 MyRange = "B2:B500"

 Range(MyRange).Select
 For Each rcell In Selection.Cells
    If Len(rcell.value) > 0 Then
        picname = Mypath & rcell.value
        mySelectRange = Replace(MyRange, "B", "A")
        IntInstr = InStr(mySelectRange, ":")
        mySelectRange = Left(mySelectRange, IntInstr - 1)
        do_insertPic picname, mySelectRange, rcell.Left, rcell.Top
     End If
Next
Application.ScreenUpdating = True
End Sub

Private Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
    Dim rcell As Range
    Range(MyRange).Select
    On Error GoTo ErrNoPhoto

    ActiveSheet.Pictures.Insert(picname).Select
    On Error GoTo 0

    With Selection
     .Left = myleft
     .Top = mytop
     .ShapeRange.LockAspectRatio = msoFalse
     .ShapeRange.Height = 80#
     .ShapeRange.Width = 80#
     .ShapeRange.Rotation = 0#
    End With
Exit Sub
ErrNoPhoto:
 MsgBox "Unable to Find Photo" 'Shows message box if picture not found
End Sub

Hi Miguel, Thanks a lot for your help! This works great and I'm able to loop through the input range and insert the pictures from my local drive. However, the pictures get inserted in the same column as my input range and I'm not able to change that to the next cell in the row. Example if MyRange is "B2:B500", the corresponding pictures get inserted in the same cells. — kisnah, Sep 28 '15 at 22:27
If you want the pictures to the left of the file names then replace "rcell.Left" in the "do_insertPic" call with a numeric 1. If you want it to the right then use a value somewhere around 200 - 250. — MiguelH, Sep 29 '15 at 07:50
Thanks! Would you be able to guide me on how to add the picture in any specified cell using the cell ID - example if I want to add picture name in cell B2 to Cell T2 and picture name in cell B3 to Cell T3. — kisnah, Sep 29 '15 at 21:02
Actually embedding a picture in a cell is difficult. There's a whole discussion about it here [http://stackoverflow.com/questions/9776611/insert-picture-into-excel-cell — MiguelH, Sep 30 '15 at 08:38
My only tip would be to record a macro and find the Left measure for your "T" column (visible if you Edit the macro) and use this along with the "B" column "Top" measure (which is already used in the code) to position your images. — MiguelH, Sep 30 '15 at 08:41

score 0 · Answer 2 · edited Dec 16 '18 at 21:04

I use following, so the sheet can be mailed etc. : 'Picname in Column B7 and corresponding picture in Column M7

Sub Picture()
    Dim picname As String
    Dim shp As Shape
    Dim pasteAt As Integer
    Dim lThisRow As Long

    lThisRow = 7 'This is the start row

    Do While (Cells(lThisRow, 2) <> "")


        pasteAt = lThisRow
        Cells(pasteAt, 13).Select 'This is where picture will be inserted (column)


        picname = Cells(lThisRow, 2) 'This is the picture name

        present = Dir("C:\foto\" & picname & ".jpg")

        If present <> "" Then

            Cells(pasteAt, 13).Select

            Call ActiveSheet.Shapes.AddPicture("C:\foto\" & picname & ".jpg", _
            msoCTrue, msoCTrue, Left:=Cells(pasteAt, 13).Left, Top:=Cells(pasteAt, 13).Top, Width:=100, Height:=100).Select


        Else
            Cells(pasteAt, 14) = "No Picture Found"
        End If

        lThisRow = lThisRow + 1
    Loop

    Range("A1").Select
    Application.ScreenUpdating = True

    Exit Sub

ErrNoPhoto:
    MsgBox "Unable to Find Photo" 'Shows message box if picture not found
    Exit Sub
    Range("O7").Select

End Sub

Insert picture corresponding to cell value using excel macro

2 Answers2