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

[firasawad]

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

 

[John_w]

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".

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

 

[firasawad]

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

 

[John_w]

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:

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

 

[firasawad]

it works thank you very much

 

[John_w]

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.

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

 

[Mussa]

@John_w is there way to expand the code to make the more flexible to include PNG,GIF even ICO?

 

[John_w]

is there way to expand the code to make the more flexible to include PNG,GIF even ICO?

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

 

[Mussa]

@John_w it just work for JPG . it doesn't work with the others.

 

[John_w]

Correction:

If InStr(1, ".jpg.png.gif.ico", Mid(imageFile, InStrRev(imageFile, ".")), vbTextCompare) Then