Insert Multiple Photos, Autofit and arrange horizontally with limit

[FaezMH]

Hi guys,

I have a problem getting a macro to run my project as I am still not that very familiar and appreciate that if anyone can give me need the advise. I intends to insert multiple pictures (as shown) however I am only able to get the 1st row right. I do not know how to start with the 2nd row and so on.

Multiselresizepics.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1
2	1ST ROW
3
4
5
6
7
8
9
10
11
12
13
14
15	2ND ROW
16
17
18
19
20
21
22
23
24
25
26
27
28	3RD ROW
29
30
31
32
33
34
35
36
37
38
39
Report

Here is my macro:
Sub Testphoto()

Dim selected_filenames As Variant
selected_filenames = Application.GetOpenFilename( _
FileFilter:="Image Files (*.jpeg;*.jpg;*.png), *.jpeg;*.jpg;*.png", _
Title:="Select Photos To Be Inserted", _
MultiSelect:=True)

If Not IsArray(selected_filenames) Then Exit Sub

Dim destination_sheet As Worksheet
Set destination_sheet = Worksheets("Report")

Dim current_image As Picture
Dim i As Long

For i = LBound(selected_filenames) To UBound(selected_filenames)
Set current_image = destination_sheet.Pictures.Insert(selected_filenames(i))
With current_image
.ShapeRange.LockAspectRatio = msoFalse
.Left = destination_sheet.Range("B3").Offset(i * 0 - 1, i * 5 - 5).Left
.Top = destination_sheet.Range("B3").Offset(i * 0 - 1, i * 5 - 5).Top
.Width = destination_sheet.Range("B3:E13").Offset(i * 1 - 1).Width
.Height = destination_sheet.Range("B3:E13").Offset(i * 1 - 1).Height
.Placement = 1
.PrintObject = True

End With
Next i

destination_sheet.Activate

End Sub

 

[KOKOSEK]

If I get it right, according to your picture each row has contains 3 pictures, so in case of 8 chosen picture, should be 3 in row 1, 3 in row 2 and 2 in row 3, correct?

Try this:

Option Explicit
Sub Testphoto()
Dim lRow As Integer: lRow = 2
Dim lCol As Integer: lCol = 1
Dim selected_filenames As Variant
selected_filenames = Application.GetOpenFilename( _
FileFilter:="Image Files (*.jpeg;*.jpg;*.png), *.jpeg;*.jpg;*.png", _
Title:="Select Photos To Be Inserted", _
MultiSelect:=True)
If Not IsArray(selected_filenames) Then Exit Sub
Dim destination_sheet As Worksheet
Set destination_sheet = Worksheets("Report")
Dim current_image As Picture
Dim i As Long

For i = LBound(selected_filenames) To UBound(selected_filenames)
    Set current_image = destination_sheet.Pictures.Insert(selected_filenames(i))
    With current_image
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = destination_sheet.Cells(lRow, 2 + (lCol * 5 - 5)).Left
        .Top = destination_sheet.Cells(lRow, 2 + (lCol * 5 - 5)).Top
        .Width = destination_sheet.Range("B3:E13").Width
        .Height = destination_sheet.Range("B3:E13").Height
        .Placement = 1
        .PrintObject = True
    End With
    lCol = lCol + 1
    If (i Mod 3) = 0 Then
        lRow = lRow + 13
        lCol = 1
    End If
Next i
End Sub

 

[FaezMH]

Hi Kokosek...you were right and this is absolutely great. You've made my day !!

Many Thanks to you.

Rgds,
Faez