Insert multiple images at once from a folder based on name from another column

[navic]

I have tried several VBA macros from the Internet, but I have not found a solution.

Folder C:\Temp\ contains images (about 1500 files, different width and height. All files are named different format name)
example: 1.jpg, 2.jpg, 3.jpg, 4.jpg, 4A.jpg, 5blok.jpg .... .etc to 1500.jpg

In the column "D" I have a image name
example:
D2 = 10
D3 = 7blok
D8 = 25
etc.

I want into cells B2, B3, B8, etc. insert images based on image name in column "D". (Only in the row containing the image name in the "D". If a cell in column D is empty, then the cells in the same row in column B should be empty)

My problem is the following:
- After starting the VBA Excel should insert images into column "B" based on their names in column "D" (but only to the row that contains the image name in the "D")
- Some images are dimensions: 154x75, 272x104, 96x150, 150x118 etc. I want to VBA all images that are wider than 100 pix reduced to 100 pixels, and the images that are less than 100 pix leave the respective width. I want set maximum image width is 100 pix (width of column B). The images height should be adjusted (adapt) to a given width. So, should keep the ratio width/height
- Finally, in each row in which the inserted picture Excel should adjust (adapt) the height row for that picture.
- When I delete files in the Temp folder, Excel needs to keep all of the images inside Workbook

I hope you understand. If you need, I will be further clarified.
Note! I use non-US Excel settings

Can someone help?

 

[tonyyy]

You might consider the following...

Sub InsertPics()
Dim fPath As String, fName As String
Dim r As Range, rng As Range

Application.ScreenUpdating = False
fPath = "C:\Temp\"
Set rng = Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row)
For Each r In rng
    fName = Dir(fPath)
    Do While fName <> ""
        If fName = r.Value Then
            With ActiveSheet.Pictures.Insert(fPath & fName)
                .ShapeRange.LockAspectRatio = msoTrue
                .Top = r.Offset(0, -2).Top
                .Left = r.Offset(0, -2).Left
                If .ShapeRange.Width > Columns(2).Width Then .ShapeRange.Width = Columns(2).Width
                Rows(r.Row).RowHeight = .ShapeRange.Height
            End With
        End If
        fName = Dir
    Loop
Next r
Application.ScreenUpdating = True
End Sub

This is based on US Excel settings.

Cheers,

tonyyy

 

[tonyyy]

The following might be a little quicker than the previous code, as it eliminates the Do Loop...

Sub InsertPicsr1()
Dim fPath As String, fName As String
Dim r As Range

Application.ScreenUpdating = False
fPath = "C:\Temp\"
For Each r In Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row)
    On Error GoTo errHandler
    If r.Value <> "" Then
        With ActiveSheet.Pictures.Insert(fPath & r.Value)
            .ShapeRange.LockAspectRatio = msoTrue
            .Top = Cells(r.Row, 2).Top
            .Left = Cells(r.Row, 2).Left
            If .ShapeRange.Width > Columns(2).Width Then .ShapeRange.Width = Columns(2).Width
            Rows(r.Row).RowHeight = .ShapeRange.Height
        End With
    End If
errHandler:
If Err.Number <> 0 Then
    Debug.Print Err.Number & ", " & Err.Description & ", " & r.Value
    On Error GoTo -1
End If
Next r
Application.ScreenUpdating = True
End Sub

 

[navic]

The following might be a little quicker than the previous code, as it eliminates the Do Loop...

Hi Tonyyy
Thank you for your response, but unsuccessful result
After starting the VBA macro nothing happens?

I'll rephrase my question

- Insert multiple JPG images at once in B column from the folder C:\Temp based on the name in D column (if in D column there is the name of the image, insert the image into B column in the same row)
- For all images that are wider than 100 pix reduced to 100 pix (keep the ratio-scale width/height). I need the possibility of independently to change this width 100 pix in the future (within the VBA code)
- Fit row height according to images in all rows-column B.

Before

After

Thanks for your time

 

[tonyyy]

The "names" in Column D have to match the images in your folder - including any file extension. So if the picture is named 231.jpg, the name in Column D must also be named 231.jpg.

If all your images are the same type (ie, have the same file extension), we can adjust the code to accommodate this.

 

[tonyyy]

If your pictures are in the .jpg format, you can try editing the following line...

With ActiveSheet.Pictures.Insert(fPath & r.Value [COLOR=#ff0000]& ".jpg"[/COLOR])

 

[navic]

If your pictures are in the .jpg format, you can try editing the following line...

Hello @tonyyy
Thank you for this great help and your taking the time.

I'm going back information to you.

This modified code works for the second VBA macro (without Do Loop). For the first VBA does not work (nothing happens after running VBA). I have tried to Excel 2007 and 2013, but the problem is the same.

Never mind, it is important that one of these two works.

But I have an additional problem. When I delete all the files in the 'C:\Temp', I reopen my Excel workbook I do not see images?
Can Excel remember images, after inserted?

 

[tonyyy]

Can Excel remember images, after inserted?

Yes, with the .AddPicture method rather than the Picture.Insert...

Sub InsertPicsr1()
Dim fPath As String, fName As String
Dim r As Range, rng As Range
Dim shpPic As Shape

Application.ScreenUpdating = False
fPath = "C:\Temp\"
Set rng = Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row)
For Each r In rng
    On Error GoTo errHandler
    If r.Value <> "" Then
        Set shpPic = ActiveSheet.Shapes.AddPicture(Filename:=fPath & r.Value & ".jpg", linktofile:=msoFalse, _
            savewithdocument:=msoTrue, Left:=Cells(r.Row, 2).Left, Top:=Cells(r.Row, 2).Top, Width:=-1, Height:=-1)
        With shpPic
            .LockAspectRatio = msoTrue
            If .Width > Columns(2).Width Then .Width = Columns(2).Width
            Rows(r.Row).RowHeight = .Height
        End With
    End If
errHandler:
If Err.Number <> 0 Then
    Debug.Print Err.Number & ", " & Err.Description & ", " & r.Value
    On Error GoTo -1
End If
Next r
Application.ScreenUpdating = True
End Sub

Oh by the way, you originally requested the pics to be <=100 pixels in width, then went on to say that your Column B was set to 100 pixels. So the code uses the width of Column B to set the maximum picture width; widen the column and your imported pictures will be wider, shrink the column and your imported pictures will be narrower.

 

[navic]

Oh by the way, you originally requested the pics to be <=100 pixels in width,......

100 pixels is the limit that I want to change in the future, this width has two options. (If the image is smaller than the width of 100 pixels so be it. This is exactly how you've done in the last VBA code).

Option A
with setting column widths

or

Option B
with setting the width in VBA code

In any case, thank you very much for the great help.
greetings from Croatia

btw: my problem solved

 

[tonyyy]

You're welcome, navic. Glad it finally worked out.

Hope to visit your fine country some day.

Cheers,

tonyyy