• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Call image from the folder to a cell that matches criteria

saamrat

Member
Hello,

Get image from a local folder to the cell if the image name matches product ID.
Kindly find the excel sheet attached. Column B has Product Id which has to be used to get the image from the folder and display it in Column D.
Kindly help

Product IdDescriptionPicture
AP101AppleImage
OR201OrangeImage
 

Attachments

  • Data_Image.xlsx
    9.2 KB · Views: 19
I have tried the following code. It inserts the image. But cannot be deleted. Anyone can help me ?
I am trying to align the image to centre. It is not possible with this code. Please help.

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim shp As Shape
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
If Target.Row Mod 20 = 0 Then Exit Sub
On Error GoTo son

For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture And shp.TopLeftCell.Address = Target.Offset(0, 2).Address Then shp.Delete
Next

If Target.Value <> "" And Dir("D:\ImgeTest\" & Target.Value & ".jpg") = "" Then
        'picture not there!
        MsgBox Target.Value & " Doesn't exist!"
End If

ActiveSheet.Pictures.Insert("D:\ImgeTest\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 2).Top
Selection.Left = Target.Offset(0, 2).Left
With Selection.ShapeRange
.LockAspectRatio = msoFalse
.Height = Target.Offset(0, 1).Height
.Width = Target.Offset(0, 3).Width
End With
Target.Offset(1, 0).Select
son:

End Sub
 
Last edited by a moderator:
Hi !​
  1. Why On Error Goto codeline ? As it can mask different issues so remove it in order to check the code behavior …

  2. Images / pictures must be saved within the workbook or just linked from the source folder ?

  3. As all is possible here if Logic is respected : Top & Left properties must be changed after Height & Width
    and all based on the same cell properties which is not the case here …
 
Hi,
Thanks for the response. I'm not well versed with VBA. I just copied the code from some other source to work with my requirement.

Images were inside the worksheet in different Tab. But when I searched internet, someone was telling me it was not possible if it is there in worksheet. So I saved images in a local folder.

Either way, can you please help me to work this out?
 
You choosed a bad code as it not matches your need ! If you need help for this code just ask where you grabbed it …​
But here, just trash it 'cause of the below !​
As it's possible from a source worksheet - many samples on web or via the VBA help - like you can yourself do it manually !​
So just activate the Macro Recorder - you know the VBA beginner best friend after the VBA help ! - then​
operate manually to copy a picture from a worksheet and to paste it to another one : you will get your own free code base​
and then, if you need some help, post the generated code here with a crystal clear complete explanation of the expected …​
 
OK, what you mean to say ia that record a macro by manually doing the required action, right?

I will give it a try
 
In the worksheet object, change the value of f to your path.
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim c As Range, r As Range, p As Range
  Dim s As Shape, f As String, fn As String, pic As Object
  Dim wPic As Single, hPic As Single
  Dim a
  
  f = ThisWorkbook.Path & "\Fruits\"
  
  Set r = Range("B10", Cells(Rows.Count, "B").End(xlUp))
  Set r = Intersect(r, Target)
  If r Is Nothing Then Exit Sub
  
  For Each c In r
    On Error Resume Next
    a = ShapeAddsToArray(ActiveSheet)
    ActiveSheet.Shapes(PosInArray(c.Offset(, 2).Address, a)).Delete
    On Error GoTo 0
    
    Set p = c.Offset(, 2) 'Column D, Picture/Shape cell to insert/add
    'fn = f & c.Offset(, 1) & ".jpg"  'Column C value
    fn = f & c & ".jpg"
    If Dir(fn) = "" Then GoTo NextC
    Set pic = ActiveSheet.Pictures.Insert(fn)
    wPic = pic.Width
    hPic = pic.Height
    pic.Delete
    Set s = ActiveSheet.Shapes.AddPicture _
      (fn, msoFalse, msoTrue, _
        p.Left, p.Top, wPic, hPic) 'embed files
    s.LockAspectRatio = True
    
    'Exact
    's.Height = p.RowHeight
    's.Left = p.Left + p.Width / 2 - s.Width / 2
    'Top and Bottom Border Space
    s.Height = p.RowHeight - 4
    s.Top = p.Top + 2
    s.Left = p.Left + p.Width / 2 - s.Width / 2
    On Error Resume Next
    s.Name = c
NextC:
  Next c
End Sub

In a Module:
Code:
Function ShapeAddsToArray(ws As Worksheet)
    Dim a, i As Integer
    If ws.Shapes.Count = 0 Then Exit Function
    ReDim a(1 To ws.Shapes.Count)
    For i = 1 To ws.Shapes.Count
        a(i) = ws.Shapes(i).TopLeftCell.Address
    Next i
    ShapeAddsToArray = a
End Function

'If array is 0 based, 1 is returned if aValue matches anArray(0).
Function PosInArray(aValue, anArray)
  Dim pos As Long
  On Error Resume Next
  pos = -1
  pos = WorksheetFunction.Match(CStr(aValue), anArray, 0)
  PosInArray = pos
End Function
 
In the worksheet object, change the value of f to your path.
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim c As Range, r As Range, p As Range
  Dim s As Shape, f As String, fn As String, pic As Object
  Dim wPic As Single, hPic As Single
  Dim a
 
  f = ThisWorkbook.Path & "\Fruits\"
 
  Set r = Range("B10", Cells(Rows.Count, "B").End(xlUp))
  Set r = Intersect(r, Target)
  If r Is Nothing Then Exit Sub
 
  For Each c In r
    On Error Resume Next
    a = ShapeAddsToArray(ActiveSheet)
    ActiveSheet.Shapes(PosInArray(c.Offset(, 2).Address, a)).Delete
    On Error GoTo 0
   
    Set p = c.Offset(, 2) 'Column D, Picture/Shape cell to insert/add
    'fn = f & c.Offset(, 1) & ".jpg"  'Column C value
    fn = f & c & ".jpg"
    If Dir(fn) = "" Then GoTo NextC
    Set pic = ActiveSheet.Pictures.Insert(fn)
    wPic = pic.Width
    hPic = pic.Height
    pic.Delete
    Set s = ActiveSheet.Shapes.AddPicture _
      (fn, msoFalse, msoTrue, _
        p.Left, p.Top, wPic, hPic) 'embed files
    s.LockAspectRatio = True
   
    'Exact
    's.Height = p.RowHeight
    's.Left = p.Left + p.Width / 2 - s.Width / 2
    'Top and Bottom Border Space
    s.Height = p.RowHeight - 4
    s.Top = p.Top + 2
    s.Left = p.Left + p.Width / 2 - s.Width / 2
    On Error Resume Next
    s.Name = c
NextC:
  Next c
End Sub

In a Module:
Code:
Function ShapeAddsToArray(ws As Worksheet)
    Dim a, i As Integer
    If ws.Shapes.Count = 0 Then Exit Function
    ReDim a(1 To ws.Shapes.Count)
    For i = 1 To ws.Shapes.Count
        a(i) = ws.Shapes(i).TopLeftCell.Address
    Next i
    ShapeAddsToArray = a
End Function

'If array is 0 based, 1 is returned if aValue matches anArray(0).
Function PosInArray(aValue, anArray)
  Dim pos As Long
  On Error Resume Next
  pos = -1
  pos = WorksheetFunction.Match(CStr(aValue), anArray, 0)
  PosInArray = pos
End Function
Thank you so much Mr. Hobson.
You are so helpful. When compared other so called "Experts" in the cyber world, you are really helping rookies. Thanks a lot
 
Hi Mr. Hobson,

There is an unusual error in the code.
Delete of Option works in "B10". Rest of the cells, it is not working unless there is a text beneath it.
Any idea ?
 
If you attach your file with VBA code, I can see what is going on.

While I based my tests on column C's for the filename, fn, the code that I posted should have worked for you.
Code:
'fn = f & c.Offset(, 1) & ".jpg"  'Column C value
 
Hi
Kindly find the attached file
Try Typing the the image name and try to delete from down
 

Attachments

  • Image_NewTest.xlsm
    19.3 KB · Views: 32
I see what is happening now. Make this change to fix the issue for deleting shapes.
Code:
'Set r = Range("B10", Cells(Rows.Count, "B").End(xlUp))
  Set r = Intersect(Range("B10", Cells(Rows.Count, "B")), ActiveSheet.UsedRange)

You may have to resize your column width depending on your pics dimensions. If the column width is not sufficient, the aspect ratio can cause the pic to not be in the proper cell when just the height is set. One can address that case but it would size to width or the height as needed depending on ratios and cell ratios. If it becomes an issue, post back.
 
If you attach your file with VBA code, I can see what is going on.

While I based my tests on column C's for the filename, fn, the code that I posted should have worked for you.
Code:
'fn = f & c.Offset(, 1) & ".jpg"  'Column C value


Hi Kenneth,

Thank you for the VBA Code, I use this code and it works really well. Only thing is when I export the spreadsheet to a PDF file via adobe acrobat it losses its VBA reset function. Is there a line of code that lets the file reset after exporting. I have to manually delete the images then exit out of Excel in order for the code to work again.
 
Back
Top