Insert picture in Excel macro which takes the file name refrence [Closed]

Question

Insert picture in Excel macro which takes the file name refrence [Closed]

Report

V Kanagu

Posts: 1
Registration date: Friday August 23, 2013
Status: Member
Last seen: August 23, 2013

- Updated on Aug 27, 2019 at 11:13 AM
TrowaD

Posts: 2690
Registration date: Sunday September 12, 2010
Status: Moderator
Last seen: January 12, 2021

- Mar 14, 2017 at 12:18 PM

Hello Friends,

Kindly help me!

I am trying to insert a picture in excel macro which takes the file name reference from the D5 cell and insert the picture in I7 cell.

Example: if D5 cell is AAA2 then the picture which will be inserted in I7 would be F:\AAA2.jpg

Note:
1. I7 cell is merged cell it cover I7 to I12 & J7 to J12
2. I change the value in D5 cell only

Please help me if, I changed the value in D5 than the Picture inserted in I7 may automatically change according to the value of D5.

Kindly help me what is the function I want to insert in macro and how to call the macro in excel.

Sorry, for the poor English

Excel vba insert picture from folder
Excel macro insert picture based on cell value - Best answers
Insert picture in excel cell automatically - Best answers
Excel vba insert picture from folder based on cell value - Forum - Excel
Excel vba insert picture - How-To - Excel
Excel vba insert picture based on cell value ✓ - Forum - Excel
Excel vba insert picture into cell ✓ - Forum - Excel
Excel vba insert multiple rows - How-To - Excel

4 replies

Answer 2 / 4

cakmak

Posts: 4
Registration date: Thursday November 6, 2014
Status: Member
Last seen: November 11, 2014

4
Nov 6, 2014 at 10:20 AM

I have my huge files and below is a sample.

I need to add photos for everycode in coloumn "A" to the same row coloumn "E"
and I want to run a macro to add photos just after I filled up the codes coloumn and other necessary information.

Lets say image files are found in "D:\images\" folder with the same names mentioned in coloumn "A"

Besides when I add the photos I want the images to be 4,6 cm height plus pictures should be placed in the center of the cell and I need the cell height to be arranged automatically also which will fit to pictures height.

Anybody can help? for this VBAless guy? :)

Thanks.

Answer 3 / 4

TrowaD

Posts: 2690
Registration date: Sunday September 12, 2010
Status: Moderator
Last seen: January 12, 2021

454
Aug 26, 2013 at 10:58 AM

Hi V Kanagu,

Here is your code:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("D5")) Is Nothing Then Exit Sub
Dim myPict As Picture

With Range("I7:J12")
Set myPict = Range("I7:J12").Parent.Pictures.Insert("F:\" & Target.Value & ".jpg")
    myPict.Top = .Top
    myPict.Width = .Width
    myPict.Height = .Height
    myPict.Left = .Left
    myPict.Placement = xlMoveAndSize
End With

End Sub

To try it out, right-click on your sheets tab, select View code.
Paste the code in the big white field.

Now change the value in D5 and see if the picture shows in your merged range.

Best regards,
Trowa

View all 10 comments

Report

TrowaD

Posts: 2690
Registration date: Sunday September 12, 2010
Status: Moderator
Last seen: January 12, 2021

454
Feb 20, 2017 at 11:45 AM

Hi Bandi,

I don't understand. When you make a change to either cell D5 or H5, that cells value will be used as picture name.

Best regards,
Trowa

Report

Bandi
Feb 21, 2017 at 06:23 PM

may i know your email address ...

Report

bandi
Feb 22, 2017 at 03:25 AM

this is my code please corectly and thanks so much for your time....
i save my pictures in folder kelas 1 .... i try insert two photos but failed
example in cell c11 i type banana then banana.jpg come then i type apple to cell v2 then apple.jpg come .... two pictures take in one sheet ("lookupgambar").

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim InsertPict As Object

Dim bolo As Object
Dim NamaFile As String

If Not Intersect(Target, Range("$C$11")) Is Nothing Then

End If

NamaFile = ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg"

If Dir(NamaFile) = "" Then NamaFile = ThisWorkbook.Path & "\NoPhoto.jpg"

Call Hapus

Set InsertPict = ActiveSheet.Pictures.Insert(NamaFile)

With InsertPict

.Name = "SuperHero"

.Top = [G3].Top
.Left = [G3].Left

.Width = [G3:L8].Width
.Height = [G3:L8].Height

.ShapeRange.Line.Visible = msoTrue
.ShapeRange.Line.Weight = 2.25

End With

If Intersect(Target, Range("$v$2")) Is Nothing Then Exit Sub

NamaFile = ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg"

If Dir(NamaFile) = "" Then NamaFile = ThisWorkbook.Path & "\NoPhoto.jpg"

Call Hapus1

Set bolo = ActiveSheet.Pictures.Insert(NamaFile)

With bolo

.Name = "Bandi"

.Top = [n3].Top
.Left = [n3].Left

.Width = [n3:q8].Width
.Height = [n3:q8].Height

.ShapeRange.Line.Visible = msoTrue
.ShapeRange.Line.Weight = 2.25

End With
End Sub

Private Sub Hapus()

On Error Resume Next

ActiveSheet.Pictures("SuperHero").Delete

End Sub
Private Sub Hapus1()

On Error Resume Next

ActiveSheet.Pictures("Bandi").Delete

End Sub

Report

TrowaD

Posts: 2690
Registration date: Sunday September 12, 2010
Status: Moderator
Last seen: January 12, 2021

454
Feb 23, 2017 at 11:44 AM

Hi Bandi,

Give the code below a try:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim myPict As Picture

If Not Intersect(Target, Range("C11")) Is Nothing Then

    With Range("G3:L8")
    Set myPict = Range("G3:L8").Parent.Pictures.Insert(ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg")
        myPict.Top = .Top
        myPict.Width = .Width
        myPict.Height = .Height
        myPict.Left = .Left
        myPict.Placement = xlMoveAndSize
    End With

ElseIf Not Intersect(Target, Range("V2")) Is Nothing Then

    With Range("N3:Q8")
    Set myPict = Range("N3:Q8").Parent.Pictures.Insert(ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg")
        myPict.Top = .Top
        myPict.Width = .Width
        myPict.Height = .Height
        myPict.Left = .Left
        myPict.Placement = xlMoveAndSize
    End With

Else
    Exit Sub
End If

End Sub

Best regards,
Trowa

Report

bandi
Feb 25, 2017 at 07:45 AM

thanks so much trowad...
very help... thanks again

Answer 4 / 4

TrowaD

Posts: 2690
Registration date: Sunday September 12, 2010
Status: Moderator
Last seen: January 12, 2021

454
Jan 18, 2016 at 11:58 AM

Hi Sachin,

For that you will need to add some ElseIf's.

I added two of them in the code of Cakmak. Look for the green text to see the start and end of these ElseIf blocks, so you could add more if needed.

Here is the adjusted code:

Private Sub CommandButton1_Click()
Dim pictureNameColumn   As String 'column where picture name is found
Dim picturePasteColumn  As String 'column where picture is to be pasted

Dim pictureName         As String 'picture name
Dim lastPictureRow      As Long   'last row in use where picture names are
Dim pictureRow          As Long   'current picture row to be processed
Dim pathForPicture      As String 'path of pictures

pictureNameColumn = "A"
picturePasteColumn = "H"

pictureRow = 5 'starts from this row

'error handler
On Error GoTo Err_Handler

'find row of the last cell in use in the column where picture names are
lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row

'stop screen updates while macro is running
Application.ScreenUpdating = False

pathForPicture = "C:\images\"
'loop till last row
Do While (pictureRow <= lastPictureRow)

    pictureName = Cells(pictureRow, "A") 'This is the picture name
    
    'if picture name is not blank then
    If (pictureName <> vbNullString) Then
    
        'check if pic is present
        
        'Start If block with .JPG
        If (Dir(pathForPicture & pictureName & ".jpg") <> vbNullString) Then
            
            Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
            ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".jpg").Select 'Path to where pictures are stored
            
            With Selection
                .Left = Cells(pictureRow, picturePasteColumn).Left
                .Top = Cells(pictureRow, picturePasteColumn).Top
                .ShapeRange.LockAspectRatio = msoFalse
                .ShapeRange.Height = 100#
                .ShapeRange.Width = 130#
                .ShapeRange.Rotation = 0#
            End With
        'End If block with .JPG
        
        'Start ElseIf block with .PNG
        ElseIf (Dir(pathForPicture & pictureName & ".png") <> vbNullString) Then
            
            Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
            ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".png").Select 'Path to where pictures are stored
            
            With Selection
                .Left = Cells(pictureRow, picturePasteColumn).Left
                .Top = Cells(pictureRow, picturePasteColumn).Top
                .ShapeRange.LockAspectRatio = msoFalse
                .ShapeRange.Height = 100#
                .ShapeRange.Width = 130#
                .ShapeRange.Rotation = 0#
            End With
        'End ElseIf block with .PNG
        
        'Start ElseIf block with .BMP
        ElseIf (Dir(pathForPicture & pictureName & ".bmp") <> vbNullString) Then
            
            Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
            ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".bmp").Select 'Path to where pictures are stored
            
            With Selection
                .Left = Cells(pictureRow, picturePasteColumn).Left
                .Top = Cells(pictureRow, picturePasteColumn).Top
                .ShapeRange.LockAspectRatio = msoFalse
                .ShapeRange.Height = 100#
                .ShapeRange.Width = 130#
                .ShapeRange.Rotation = 0#
            End With
        'End ElseIf block with .BMP
        
        Else
            'picture name was there, but no such picture
            Cells(pictureRow, picturePasteColumn) = "No Picture Found"
        End If
        
    Else
    'picture name cell was blank
    End If
    'increment row count
    pictureRow = pictureRow + 1
Loop

Exit_Sub:
Range("A10").Select
Application.ScreenUpdating = True
Exit Sub

Err_Handler:
MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
GoTo Exit_Sub

End Sub

Best regards,
Trowa

Report

ssincerely

Posts: 3
Registration date: Sunday October 9, 2016
Status: Member
Last seen: October 12, 2016

Oct 9, 2016 at 03:30 AM

I really found this helpful a lot but I stumbled unto something. The Pictures keep pasting over each other making the workbook increase in size. Is there a way to have the Pictures replaced the ones that are there?

Report

Linesh Lohidakshan
Mar 13, 2017 at 12:38 PM

Pls. Thank you very much for the codes. But in some cases if the images are missing the next image is copied in to that cell instead of showing No picture found.

Can you pls help.

Report

TrowaD

Posts: 2690
Registration date: Sunday September 12, 2010
Status: Moderator
Last seen: January 12, 2021

454
Mar 14, 2017 at 12:18 PM

Hi Linesh,

Just tested the code from post 10 and it shows "No Picture Found" when the image isn't found. Maybe the picture is overlapping the text?

Best regards,
Trowa

Ask a question

Hi Trowa,

Your code to insert picture works find.

However, I have an additional requirement. i.e. when i delete the value in D5 the loaded image should also get cleared (or) when i change the value in D5, the earlier loaded image should be cleared and a new image need to be loaded in i7:j12.

Could you help me out on this.
Sure Sriram,

See if the code below does as requested:
Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, Range("D5")) Is Nothing Then Exit Sub Dim myPict As Picture ActiveSheet.Pictures.Delete If Target.Value = vbNullString Then Exit Sub With Range("I7:J12") Set myPict = Range("I7:J12").Parent.Pictures.Insert("F:\" & Target.Value & ".jpg") myPict.Top = .Top myPict.Width = .Width myPict.Height = .Height myPict.Left = .Left myPict.Placement = xlMoveAndSize End With End Sub

Bestr egards,
Trowa
hi... anyone can help me make two target when take picture ... like D5 and h5 thanks
Hi Bandi,

Replace the 2nd code line with:
If Intersect(Target, Range("D5","H5")) Is Nothing Then Exit Sub

Best regards,
Trowa
hi TrowaD,
thanks so much... one question again, please help me... how insert two or three pictures with different target... example : D5 to apple.jpg and H5 to orange.jpg .... i had try like code up but failed ... please and thanks again for your time
Hi Bandi,

I don't understand. When you make a change to either cell D5 or H5, that cells value will be used as picture name.

Best regards,
Trowa
this is my code please corectly and thanks so much for your time....
i save my pictures in folder kelas 1 .... i try insert two photos but failed
example in cell c11 i type banana then banana.jpg come then i type apple to cell v2 then apple.jpg come .... two pictures take in one sheet ("lookupgambar").

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim InsertPict As Object

Dim bolo As Object
Dim NamaFile As String

If Not Intersect(Target, Range("$C$11")) Is Nothing Then

End If

NamaFile = ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg"

If Dir(NamaFile) = "" Then NamaFile = ThisWorkbook.Path & "\NoPhoto.jpg"

Call Hapus

Set InsertPict = ActiveSheet.Pictures.Insert(NamaFile)

With InsertPict

.Name = "SuperHero"

.Top = [G3].Top
.Left = [G3].Left

.Width = [G3:L8].Width
.Height = [G3:L8].Height

.ShapeRange.Line.Visible = msoTrue
.ShapeRange.Line.Weight = 2.25

End With

If Intersect(Target, Range("$v$2")) Is Nothing Then Exit Sub

NamaFile = ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg"

If Dir(NamaFile) = "" Then NamaFile = ThisWorkbook.Path & "\NoPhoto.jpg"

Call Hapus1

Set bolo = ActiveSheet.Pictures.Insert(NamaFile)

With bolo

.Name = "Bandi"

.Top = [n3].Top
.Left = [n3].Left

.Width = [n3:q8].Width
.Height = [n3:q8].Height

.ShapeRange.Line.Visible = msoTrue
.ShapeRange.Line.Weight = 2.25

End With
End Sub

Private Sub Hapus()

On Error Resume Next

ActiveSheet.Pictures("SuperHero").Delete

End Sub
Private Sub Hapus1()

On Error Resume Next

ActiveSheet.Pictures("Bandi").Delete

End Sub
Hi Bandi,

Give the code below a try:
Private Sub Worksheet_Change(ByVal Target As Range) Dim myPict As Picture If Not Intersect(Target, Range("C11")) Is Nothing Then With Range("G3:L8") Set myPict = Range("G3:L8").Parent.Pictures.Insert(ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg") myPict.Top = .Top myPict.Width = .Width myPict.Height = .Height myPict.Left = .Left myPict.Placement = xlMoveAndSize End With ElseIf Not Intersect(Target, Range("V2")) Is Nothing Then With Range("N3:Q8") Set myPict = Range("N3:Q8").Parent.Pictures.Insert(ThisWorkbook.Path & "\KELAS1\" & Target.Value & ".jpg") myPict.Top = .Top myPict.Width = .Width myPict.Height = .Height myPict.Left = .Left myPict.Placement = xlMoveAndSize End With Else Exit Sub End If End Sub

Best regards,
Trowa
I really found this helpful a lot but I stumbled unto something. The Pictures keep pasting over each other making the workbook increase in size. Is there a way to have the Pictures replaced the ones that are there?
Pls. Thank you very much for the codes. But in some cases if the images are missing the next image is copied in to that cell instead of showing No picture found.

Can you pls help.
Hi Linesh,

Just tested the code from post 10 and it shows "No Picture Found" when the image isn't found. Maybe the picture is overlapping the text?

Best regards,
Trowa

TrowaD · Accepted Answer · 2014-11-06T11:04:01-0500

Answer 1 / 4

TrowaD

Posts: 2690
Registration date: Sunday September 12, 2010
Status: Moderator
Last seen: January 12, 2021

454
Nov 6, 2014 at 11:04 AM

Hi Cakmak,

Try the code below.
The picture height is determined by the row height and not the other way around, because screen size is also a factor.

Here is the code:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("A:A")) Is Nothing Then Exit Sub
Dim myPict As Picture

With Cells(Target.Row, "D")
Set myPict = Cells(Target.Row, "D").Parent.Pictures.Insert("D:\images\" & Target.Value & ".jpg")
    myPict.Top = .Top
    myPict.Width = .Width
    myPict.Height = .Height
    myPict.Left = .Left
    myPict.Placement = xlMoveAndSize
End With

End Sub

Best regards,
Trowa

View all 6 comments

Report

cakmak

Posts: 4
Registration date: Thursday November 6, 2014
Status: Member
Last seen: November 11, 2014

4
Nov 11, 2014 at 06:44 AM

Dear Trowa,

Here is the code I am using for my excel macro with a button.

While using it I have seen that I need some more modification which lets me to :

1. Keep aspect ratio of pictures
2. Move and size with cells.

for the images.

Is it possible to do that?

Thanks.

Private Sub CommandButton1_Click()
Dim pictureNameColumn   As String 'column where picture name is found
Dim picturePasteColumn  As String 'column where picture is to be pasted

Dim pictureName         As String 'picture name
Dim lastPictureRow      As Long   'last row in use where picture names are
Dim pictureRow          As Long   'current picture row to be processed
Dim pathForPicture      As String 'path of pictures

    pictureNameColumn = "A"
    picturePasteColumn = "H"
    
    pictureRow = 5 'starts from this row
    
    'error handler
    On Error GoTo Err_Handler
    
    'find row of the last cell in use in the column where picture names are
    lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row
    
    'stop screen updates while macro is running
    Application.ScreenUpdating = False
    
    pathForPicture = "C:\images\"
    'loop till last row
    Do While (pictureRow <= lastPictureRow)
     
        pictureName = Cells(pictureRow, "A") 'This is the picture name
        
        'if picture name is not blank then
        If (pictureName <> vbNullString) Then
            'check if pic is present
            If (Dir(pathForPicture & pictureName & ".jpg") <> vbNullString) Then
            
                Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
                ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".jpg").Select 'Path to where pictures are stored
                
                With Selection
                    .Left = Cells(pictureRow, picturePasteColumn).Left
                    .Top = Cells(pictureRow, picturePasteColumn).Top
                    .ShapeRange.LockAspectRatio = msoFalse
                    .ShapeRange.Height = 100#
                    .ShapeRange.Width = 130#
                    .ShapeRange.Rotation = 0#
                End With
            Else
                'picture name was there, but no such picture
                Cells(pictureRow, picturePasteColumn) = "No Picture Found"
            End If
        Else
            'picture name cell was blank
        End If
        'increment row count
        pictureRow = pictureRow + 1
    Loop
     
Exit_Sub:
    Range("A10").Select
    Application.ScreenUpdating = True
    Exit Sub
    
Err_Handler:
     MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
    GoTo Exit_Sub

End Sub

Report

TrowaD

Posts: 2690
Registration date: Sunday September 12, 2010
Status: Moderator
Last seen: January 12, 2021

454
Nov 11, 2014 at 11:31 AM

Hi Cakmak,

1.
To keep aspect ratio change:
.ShapeRange.LockAspectRatio = msoFalse
into:
.ShapeRange.LockAspectRatio = msoTrue

2.
Try this, but know that this overwrites the aspect ratio:

With Selection
    .Left = Cells(pictureRow, picturePasteColumn).Left
    .Top = Cells(pictureRow, picturePasteColumn).Top
    .ShapeRange.LockAspectRatio = msoTrue 'Point 1
    .ShapeRange.Height = 10#
    .ShapeRange.Width = 130#
    .ShapeRange.Rotation = 0#
    .Placement = xlMoveAndSize 'Point 2
End With

Best regards,
Trowa

Report

sachin > TrowaD

Posts: 2690
Registration date: Sunday September 12, 2010
Status: Moderator
Last seen: January 12, 2021

Jan 12, 2016 at 04:53 AM

hi trowa,

above same code I want add .jgp,png,jpeg.picure file.please help.aspa

Report

TrowaD

Posts: 2690
Registration date: Sunday September 12, 2010
Status: Moderator
Last seen: January 12, 2021

454
Jan 12, 2016 at 11:09 AM

Hi Sachin,

What is the issue you are experiencing? Have you tried replacing ".jpg" by either ".png" or ".jpeg"?

Best regards,
Trowa

Report

sachin
Jan 14, 2016 at 02:11 AM

Hi Trowa,

At the moment I can only add photos of a certain file such as .jpg or .jpeg. In my older its all mixed and thats where the problem is. All of them are not the same.

thanks
Sachin

Insert picture in Excel macro which takes the file name refrence [Closed]

4 replies

Your reply

Subscribe To Our Newsletter!