Inserting multiple (specific) images from a folder

[dafydd_jwc]

I have a spreadsheet of all the stock our company has, and would like to add images to it (we produce board games & jigsaws!). We have product codes - a letter and 3 or 4 digits (e.g. A123)

All the images will be named as their product code - e.g. "A123.jpg"

I have a column which has all the codes, I have a column which has concatenated the product code and '.jpg', but I don't know how to write the code to insert the image associated with that product in the next cell over. The images would need to go into column D, starting at cell D2.

Hope someone is able to help!

 

[dafydd_jwc]

This sort of idea.

 

[KOKOSEK]

There is a issue about size on cell --> size of picture. If you have standard size of cells, picture will be really small.
Run InsertPictureFromCells().

Option Explicit
Function InsPict(ByVal PicFilename As String, ByVal Target As Range) As String
Dim p As IPictureDisp, t As Double, L As Double
Dim w As Double, h As Double
Dim InsPic As Shape
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Function
    On Error Resume Next
    Target.Parent.Shapes("R" & Target.Row & "C" & Target.Column).Delete
    On Error GoTo 0
    If Dir(PicFilename) = "" Then Exit Function
    Set p = LoadPicture(PicFilename)
    w = Target.Width - 2
    h = w * p.Height / p.Width
    If h > Target.Height - 2 Then
        h = Target.Height
        w = h * p.Width / p.Height
    End If
    With Target
        Set InsPic = .Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, .Left, .Top, w, h)
    End With
    Set p = Nothing
    If Not InsPic Is Nothing Then
        InsPic.Name = "R" & Target.Row & "C" & Target.Column
        InsPic.LockAspectRatio = msoTrue
        InsPic.Left = Target.Left + (Target.Width - InsPic.Width) / 2
        InsPic.Top = Target.Top + (Target.Height - InsPic.Height) / 2
    End If
    InsPict = ""
End Function

Sub InsertPictureFromCells()
Dim cell As Range
With ActiveSheet
    For Each cell In .Range("C2:C" & .Cells(Rows.Count, "C").End(xlUp).Row)
        cell.Offset(0, 1).Value = InsPict(cell.Value, cell.Offset(0, 1))
    Next cell
End With
End Sub

 

[KOKOSEK]

With declared pictures size (then cell is automatically resize to fit it in).

InsPict(cell_with_JPG path, cell where picture have to be, sizeW, sizeH)

Option Explicit
Function InsPict(ByVal PicFilename As String, ByVal Target As Range, maxW As Integer, maxH As Integer) As String
Dim p As IPictureDisp, t As Double, L As Double
Dim w As Double, h As Double
Dim InsPic As Shape
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Function
    On Error Resume Next
    Target.Parent.Shapes("R" & Target.Row & "C" & Target.Column).Delete
    On Error GoTo 0
    If Dir(PicFilename) = "" Then Exit Function
    Set p = LoadPicture(PicFilename)
    w = maxW
    h = w * p.Height / p.Width
    If h > maxH Then
        h = Target.Height
        w = h * p.Width / p.Height
    End If
    With Target
        Set InsPic = .Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, .Left, .Top, w, h)
    End With
    Set p = Nothing
    If Not InsPic Is Nothing Then
        InsPic.Name = "R" & Target.Row & "C" & Target.Column
        InsPic.LockAspectRatio = msoFalse
        Rows(Target.Row).RowHeight = InsPic.Height
        Columns(Target.Column).ColumnWidth = InsPic.Width * (54.29 / 288)
        InsPic.Left = Target.Left + (Target.Width - InsPic.Width) / 2
        InsPic.Top = Target.Top + (Target.Height - InsPic.Height) / 2
    End If
    InsPict = ""
End Function

Sub InsertPictureFromCells()
Dim cell As Range
With ActiveSheet
    For Each cell In .Range("C2:C" & .Cells(Rows.Count, "C").End(xlUp).Row)
        cell.Offset(0, 1).Value = InsPict(cell.Value, cell.Offset(0, 1), 100, 100)
    Next cell
End With
End Sub