Macro inserting images in certain cells

[Ilfalco87]

Hello,

I'm trying to set up a marco to insert images into certain cells for reporting needs.

This is the format :

This is what I got so far (all credits to Google search), the macro pulls in the images into cells, but not in a range of cells (necessary) and I can only put them next to each other.

Sub InsertPictures()

Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
        xRowIndex = xRowIndex + 1
    Next
End If
End Sub

Thank you for helping me out!

 

[Ilfalco87]

 

[Ilfalco87]

To be clear, in this order and in a loop till there are no images left (could be more than 600).

 

[Perpa]

To be clear, in this order and in a loop till there are no images left (could be more than 600).

Ilfalco87,
Welcome to the forum.
600 is a lot of pictures! I was more curious about the method, than the number of pictures. This a variation of something I came up with recently on another thread on this forum. It will get you close.
Note that the size of your images may not fit exactly side to side, and top to bottom without some distortion of the image.
I chose instead to hold the HEIGHT and let the width vary. I used HEIGHT of '150' in this code. Give this a try on a copy of your workbook with 20 or so pictures.
You can adjust that number up or down depending on the fit to your cell sizes.
The code first makes a copy of all the picture names in the filepath you give in the msgbox that comes up. I chose sheet "Photo" of the workbook to put the names. You can change that, but you will have to change all the "Photo" references in the code as well.
Copy this code into a standard module using Alt+F11, then copy and paste to the 'General' window. Then close and save your workbook as 'macro enabled'.
To Run the code press Alt+F8, then select 'AddOlEObject_600', then 'Run'. Adjust the image 'Height' in the two places in the code until it fits your range height.
Let us know how it goes. Good luck.
Perpa

Sub AddOlEObject_600()
    Dim mainWorkBook As Workbook
    Dim counter, rw1,rw2, LR, pn1, pn2 As Long
    Dim noPicFrames, TotalColsReqd, picCol As Long
    Application.ScreenUpdating = False
    Set mainWorkBook = ActiveWorkbook
    Sheets("Sheet1").Activate    'Change the sheet name from "Sheet1" to the sheet name where you want your pictures
    
    'Clear Sheet1 & Photo
    ActiveSheet.UsedRange.ClearContents
    For Each sh In Sheets("Sheet1").Shapes
       sh.Delete
    Next sh
    Sheets("Photo").UsedRange.ClearContents
    'Change the folderpath to wherever your pictures are coming from
    Folderpath = InputBox("Enter the complete folder path to your files" & Chr(13) & " in this format: 'C:\yourPath\folder1'")
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    'This next code makes a list on Photo column A of the complete path and filename of all the pictures
    rw2 = 1
    For Each fls In listfiles
        Sheets("Photo").Range("A" & rw2).Value = fls
        rw2 = rw2 + 1
    Next fls
    LR = Sheets("Photo").Range("A" & Rows.Count).End(xlUp).Row
'600 pictures means there would be 50 each 12-picture frames!
noPicFrames = NoOfFiles / 6
TotalColsReqd = noPicFrames * 39    'There are 38 columns between each batch of 6 pictures
For picCol = 40 To TotalColsReqd Step 38    'Sets up each block of 38 columns
    'LH Side first
    rw1 = 14
    For pn1 = 1 To NoOfFiles Step 2
        If pn1 <> "" Then
            Cells(rw1, picCol).Activate
                 
                With ActiveSheet.Pictures.Insert(Sheets("Photo").Range("A" & pn1).Value, pn1)
                    With .ShapeRange
                        .LockAspectRatio = msoTrue    'If you uncomment both Width and Height lines below change to 'msoFalse'
                        '.Width = 50      'Adjust to change the WIDTH of your pictures - COMMENTED OUT
                        .Height = 150    'Adjust to change the HEIGHT of your pictures
                    End With
                    .Left = ActiveSheet.Range(Cells(rw1, picCol), Cells(rw1 + 14, picCol + 17)).Left
                    .Top = ActiveSheet.Range(Cells(rw1, picCol), Cells(rw1 + 14, picCol + 17)).Top
                    .Placement = 1
                    .PrintObject = True
                End With
        End If
        rw1 = rw1 + 15
        If rw1 > 44 Then
            rw1 = 14
            picCol = picCol + 38
        End If
    Next pn1
Next picCol
 'RH Side Next
For picCol = 58 To TotalColsReqd Step 38
    rw1 = 14
    For pn2 = 2 To NoOfFiles Step 2
        If pn2 <> "" Then
            Cells(rw1, picCol).Activate
            With ActiveSheet.Pictures.Insert(Sheets("Photo").Range("A" & pn2).Value, pn2)
                With .ShapeRange
                    .LockAspectRatio = msoTrue    'If you uncomment both Width and Height lines below change to 'msoFalse'
                    '.Width = 50      'Adjust to change the WIDTH of your pictures - COMMENTED OUT
                    .Height = 150    'Adjust to change the HEIGHT of your pictures
                End With
                .Left = ActiveSheet.Range(Cells(rw1, picCol), Cells(rw1 + 14, picCol + 17)).Left
                .Top = ActiveSheet.Range(Cells(rw1, picCol), Cells(rw1 + 14, picCol + 17)).Top
                .Placement = 1
                .PrintObject = True
            End With
        End If
        rw1 = rw1 + 15
        If rw1 > 44 Then
            rw1 = 14
            picCol = picCol + 38
        End If
        
    Next pn2
Next picCol
Sheets("Sheet1").Activate
Application.ScreenUpdating = True
End Sub