VBA - Macro for getting pictures from file that match cell value

firasawad

New Member
Joined
Nov 7, 2021
Messages
3
Office Version
  1. 2016
Platform
  1. Windows
Hi All,

i don't seem to find the VBA anywhere online,i have been searching for the last 5 hours. need your help

my images stored is in the shared folder \\191.128.5.296\Marina FileServer\E-Commerce_Share\Website Photo\All website photo

I want to get the image that matches name/code in column C and put, resize it in column D.
note that I have 1500 codes that need to be Matched with pictures

for example :
Code
AAG1045_1 in column B should match with picture name AAG1045_1 in the shared folder



can you please help with that



1636271555650.png
 

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).
Your description mixes columns B/C and C/D. Try this macro, though I'm not sure if it will work with your shared folder. Assumes the image files have extension ".jpg".
VBA Code:
Public Sub Add_Images_To_Cells()

    Const folderPath As String = "\\191.128.5.296\Marina FileServer\E-Commerce_Share\Website Photo\All website photo\"
    
    Dim r As Long
    
    Application.ScreenUpdating = False
    With ActiveSheet
        For r = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
            If Dir(folderPath & .Cells(r, "B").Value & ".jpg") <> vbNullString Then
                .Shapes.AddPicture Filename:=folderPath & .Cells(r, "B").Value & ".jpg", _
                                   LinkToFile:=False, SaveWithDocument:=True, _
                                   Left:=.Cells(r, "C").Left, Top:=.Cells(r, "C").Top, Width:=.Cells(r, "C").Width, Height:=.Cells(r, "C").Height
            End If
            DoEvents
        Next
    End With
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub
 
Upvote 0
didn't work,

I even moved the picture path to a local folder, nothing happens.

Can we skip to the line if the picture is not found? and add "not found" to the cell where picture cant be found


CODE:

Public Sub Add_Images_To_Cells()

Const folderPath As String = "D:\All website photo"

Dim r As Long

Application.ScreenUpdating = False
With ActiveSheet
For r = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
If Dir(folderPath & .Cells(r, "B").Value & ".jpg") <> vbNullString Then
.Shapes.AddPicture Filename:=folderPath & .Cells(r, "B").Value & ".jpg", _
LinkToFile:=False, SaveWithDocument:=True, _
Left:=.Cells(r, "C").Left, Top:=.Cells(r, "C").Top, Width:=.Cells(r, "C").Width, Height:=.Cells(r, "C").Height
End If
DoEvents
Next
End With
Application.ScreenUpdating = True

MsgBox "Done"

End Sub
 
Upvote 0
didn't work,

I even moved the picture path to a local folder, nothing happens.
It didn't work with a local folder because you omitted the back slash at the end of the path.
Can we skip to the line if the picture is not found? and add "not found" to the cell where picture cant be found
Try this macro:
VBA Code:
Public Sub Add_Images_To_Cells()

    Const folderPath As String = "D:\All website photo\"
    
    Dim r As Long
    
    Application.ScreenUpdating = False
    With ActiveSheet
        For r = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
            If Dir(folderPath & .Cells(r, "B").Value & ".jpg") <> vbNullString Then
                .Shapes.AddPicture Filename:=folderPath & .Cells(r, "B").Value & ".jpg", _
                                   LinkToFile:=False, SaveWithDocument:=True, _
                                   Left:=.Cells(r, "C").Left, Top:=.Cells(r, "C").Top, Width:=.Cells(r, "C").Width, Height:=.Cells(r, "C").Height
            Else
                .Cells(r, "C").Value = "Not found"
            End If
            DoEvents
        Next
    End With
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub
 
Upvote 0
Solution
Your OP shows autofilter enabled. This updated macro sets the Placement property of each image to xlMoveAndSize, so that the image stays in the correct row if you filter the data, say by the Category column.
VBA Code:
Public Sub Add_Images_To_Cells2()

    Const folderPath As String = "D:\All website photo\"
    
    Dim r As Long
    Dim image As Shape
    
    Application.ScreenUpdating = False
    
    With ActiveSheet
        For r = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
            If Dir(folderPath & .Cells(r, "B").Value & ".jpg") <> vbNullString Then
                Set image = .Shapes.AddPicture(Filename:=folderPath & .Cells(r, "B").Value & ".jpg", _
                                               LinkToFile:=False, SaveWithDocument:=True, _
                                               Left:=.Cells(r, "C").Left, Top:=.Cells(r, "C").Top, Width:=.Cells(r, "C").Width, Height:=.Cells(r, "C").Height)
                With image
                    .Placement = xlMoveAndSize
                    .DrawingObject.PrintObject = True
                End With
            Else
                .Cells(r, "C").Value = "Not found"
            End If
            DoEvents
        Next
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub
 
Upvote 0
@John_w is there way to expand the code to make the more flexible to include PNG,GIF even ICO?
 
Upvote 0
is there way to expand the code to make the more flexible to include PNG,GIF even ICO?
VBA Code:
Public Sub Add_Images_To_Cells2()

    Const folderPath As String = "D:\All website photo\"
    
    Dim r As Long
    Dim imageFile As String
    Dim image As Shape
    
    Application.ScreenUpdating = False
    With ActiveSheet
        For r = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
            imageFile = Dir(folderPath & .Cells(r, "B").Value & ".*")
            If InStr(1, ".jpg.png.gif.ico", Mid(imageFile, InStrRev(imageFile, ".")), vbTextCompare) = 1 Then
                Set image = .Shapes.AddPicture(Filename:=folderPath & imageFile, _
                                               LinkToFile:=False, SaveWithDocument:=True, _
                                               Left:=.Cells(r, "C").Left, Top:=.Cells(r, "C").Top, Width:=.Cells(r, "C").Width, Height:=.Cells(r, "C").Height)
                With image
                    .Placement = xlMoveAndSize
                    .DrawingObject.PrintObject = True
                End With
            Else
                .Cells(r, "C").Value = "Not found"
            End If
            DoEvents
        Next
    End With
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub
 
Upvote 0
Correction:
VBA Code:
If InStr(1, ".jpg.png.gif.ico", Mid(imageFile, InStrRev(imageFile, ".")), vbTextCompare) Then
 
Upvote 0

Forum statistics

Threads
1,213,535
Messages
6,114,192
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top