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

 

[Mussa]

it works. thanks so much

 

[Hasson]

@John_w I note when run the code repeatedly . it will copy the picture in cells for many time .I'm asking if there is way just copy one time when I run macro continuously?
because it will affect size the file when run the macro continuously . it's useless to copy the picture in the same cell for many times it will make bigger file size

 

[John_w]

I note when run the code repeatedly . it will copy the picture in cells for many time .I'm asking if there is way just copy one time when I run macro continuously?

Try this modified code.

Public Sub Add_Images_To_Cells2()

    Const folderPath As String = "D:\All website photo\"
    
    Dim allPics As String
    Dim r As Long
    Dim imageFile As String
    Dim image As Shape
    
    Application.ScreenUpdating = False
    
    With ActiveSheet
    
        allPics = ""
        For r = 1 To .Shapes.Count
            If .Shapes(r).Type = msoPicture Then allPics = allPics & .Shapes(r).TopLeftCell.Address & ","
        Next
    
        For r = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
            If InStr(allPics, .Cells(r, "C").Address & ",") = 0 Then
                imageFile = Dir(folderPath & .Cells(r, "B").Value & ".*")
                If InStr(1, ".jpg.png.gif.ico", Mid(imageFile, InStrRev(imageFile, ".")), vbTextCompare) 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
            End If
        Next
    
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub

 

[Hasson]

thanks , but it gives error "invalid procedure call or argument" in this line

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

 

[John_w]

Is the folder correct?

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

If not, change the string to the correct folder.

 

[Hasson]

absolutely . this is the same thing. when I create th folder in drive D i use copy & paste to rename the folder as is in the code .

 

[Hasson]

I've found the problem is when start the data from row 2 it will show the error , but if it starts from row1 works perfectly

how can i fix this problem because in row 1 is topics headers, any idea?

 

[John_w]

I've found the problem is when start the data from row 2 it will show the error , but if it starts from row1 works perfectly

how can i fix this problem because in row 1 is topics headers, any idea?

The code should work for you because these 2 lines expect the image names in column B starting at row 2:

For r = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row

imageFile = Dir(folderPath & .Cells(r, "B").Value & ".*")

 

[Hasson]

I tried much for more than PC and file , but nothing changes. the error still shows .so I would share my file may be find out something .
imag.xlsm
thanks again

 

[John_w]

thanks , but it gives error "invalid procedure call or argument" in this line

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

That error occurs if a file in the folderPath doesn't match the name in column B. For example, with the names 1, 2, aaa in your workbook the code is looking for files matching 1.*, 2.* and aaa.* in the folderPath. I've changed the macro to check for this possibility, and changed the 'Not found' text put in column C, depending on whether no file matching the name was found, or a file was found but doesn't match a known file extension (.jpg, .png, .gif, .ico).

Public Sub Add_Images_To_Cells2()

    Const folderPath As String = "D:\All website photo\"
    
    Dim allPics As String
    Dim r As Long
    Dim imageFile As String
    Dim image As Shape
    
    Application.ScreenUpdating = False
    
    With ActiveSheet
    
        allPics = ""
        For r = 1 To .Shapes.Count
            If .Shapes(r).Type = msoPicture Then allPics = allPics & .Shapes(r).TopLeftCell.Address & ","
        Next
    
        For r = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
            If InStr(allPics, .Cells(r, "C").Address & ",") = 0 Then
                imageFile = Dir(folderPath & .Cells(r, "B").Value & ".*")
                If imageFile <> vbNullString Then
                    If InStr(1, ".jpg,.png,.gif,.ico,", Mid(imageFile, InStrRev(imageFile, ".") & ","), vbTextCompare) Then
                        .Cells(r, "C").ClearContents
                        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 = "Found '" & imageFile & "' but not a known image"
                    End If
                    DoEvents
                Else
                    .Cells(r, "C").Value = "No file found matching '" & .Cells(r, "B").Value & ".*'"
                End If
            End If
        Next
    
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"
    
End Sub