VBA Macro Import Based on Cell Value

[spectraflame]

Column A will contain the matching photo after macro runs
Column B contains the part number

Marco is going to import photo based on name of value in column B from local path based on cell range.

B2=10101 - Has photo in directory
B3=10102 - Has photo in directory
B4=10103 - Does not have photo in directory
B5=10104 - Has photo in directory
B6=10105 - Has photo in directory

Sub INSERT_PICS()
On Error Resume Next
Dim IMAGE As Picture
Dim PIC_PATH As String
Dim PART_NUM As String

For i = 2 To 6

PART_NUM = Worksheets("ITEM_LISTING").Cells(i, 2).Value
PIC_PATH = "C:\TMP\PART PICTURES\" & Worksheets("ITEM_LISTING").Cells(i, 2).Value & ".jpg"

With Worksheets("ITEM_LISTING").Cells(i, 1)
Set IMAGE = ActiveSheet.Pictures.Insert(PIC_PATH)
IMAGE.Top = .Top
IMAGE.Left = .Left
IMAGE.ShapeRange.LockAspectRatio = msoFalse
IMAGE.Placement = xlMoveAndSize
IMAGE.ShapeRange.Width = 160
IMAGE.ShapeRange.Height = 89.92
End With

Next
Worksheets("ITEM_LISTING").Cells(1, 1).Select
End Sub

The idea is to populate the spreadsheet with desired data in columns C-J and then run the macro to import the image of the part based on the value in Column B. This works fine until it reaches a part number that does not have a corresponding photo in this case cell B3. The result is:

A2 = Correct Photo
A3 = No Photo
A4 = Photo for B3
A5 = Correct Photo
A6 = Correct Photo

What modifications does the code need to step through each cell value in column B and only import the photo when there is a match? I do not understand how the code is taking the photo for B3 and moving it to B4 but the rest of the part number images are correct.

I appreciate your input.

 

[spectraflame]

Would a more logical approach be to create an image that reads "No Pic Available" and have an IF statement to check to see if the cell value has a matching photo and then insert the No Pic image in its place?

 

[GWteB]

What modifications does the code need to step through each cell value in column B and only import the photo when there is a match?

Just check if such a file exists, see the additions I made in your code below.

I do not understand how the code is taking the photo for B3 and moving it to B4 but the rest of the part number images are correct.

Because of the On Error Resume Next on top of your procedure, you will never be warned about run-time errors. This results in the code continuing to execute after an error, but in an incorrect context.

Sub INSERT_PICS()
'    On Error Resume Next
    Dim IMAGE As Picture
    Dim PIC_PATH As String
    Dim PART_NUM As String

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    For i = 2 To 6

        PART_NUM = Worksheets("ITEM_LISTING").Cells(i, 2).Value
        PIC_PATH = "C:\TMP\PART PICTURES\" & Worksheets("ITEM_LISTING").Cells(i, 2).Value & ".jpg"

        If fso.FileExists(PIC_PATH) Then
        
            With Worksheets("ITEM_LISTING").Cells(i, 1)
                Set IMAGE = ActiveSheet.Pictures.Insert(PIC_PATH)
                IMAGE.Top = .Top
                IMAGE.Left = .Left
                IMAGE.ShapeRange.LockAspectRatio = msoFalse
                IMAGE.Placement = xlMoveAndSize
                IMAGE.ShapeRange.Width = 160
                IMAGE.ShapeRange.Height = 89.92
            End With
        End If
    Next
    Worksheets("ITEM_LISTING").Cells(1, 1).Select
End Sub

 

[spectraflame]

Thanks for fixing my mistakes. I had the Resume Next because if the code encountered a cell where there was no photo, it would stop. I can see how your code addition is verifying there is a match and then skipping to the next entry if there is no good match found.

Thanks again,

 

[GWteB]

You are welcome and thanks for the feedback.