To import all picture from folder and sort into specific cell

[Megat91]

Hello
i have dynamic number of picture in folder namely path "C:\Users\User\Pictures\" but not exceeding 30 pictures
i want to create macro to import all picture from this folder into below specific cell in "Sheet1".
D11,J11,P11,V11,AB11,D19,J19,P19,V19,AB19,D27,J27,P27,V27,AB27,D35,J35,P35,V35,AB35,D43,J43,P43,V43,AB43,D51,J51,P51,V51,AB51
i want it to fill up the cell accordingly from D11 to AB11 then continue at D19 to Ab19 and so on
and i want the picture to set in as same as "place in cell" format
can it be done in macro? rather than i have to click insert - picture - place in cell - select the picture in folder 1 by 1

Thanks!

 

[NdNoviceHlp]

Hi Megat91. You can trial this code. HTH. Dave

Sub InsertPictures()
Dim SFolder As Object, FSO As Object, Opic As Object
Dim sFile As Object, CellArr As Variant
Dim ws As Worksheet, ArCnt As Integer
Set ws = ActiveSheet ' or a specific sheet
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SFolder = FSO.GetFolder("C:\Users\User\Pictures\")   '<----- Where the pictures are. Change as needed

CellArr = Array("D11", "J11", "P11", "V11", "AB11", "D19", "J19", "P19", "V19", _
                  "AB19", "D27", "J27", "P27", "V27", "AB27", "D35", "J35", "P35", _
                     "V35", "AB35", "D43", "J43", "P43", "V43", "AB43", "D51", "J51", "P51", "V51", "AB51")
ArCnt = 0
For Each sFile In SFolder.Files
Set Opic = Application.ActiveSheet.Shapes.AddPicture(SFolder.Path & "\" & sFile.Name, False, True, 1, 1, 1, 1)
Opic.Left = ws.Range(CellArr(ArCnt)).Left
Opic.Top = ws.Range(CellArr(ArCnt)).Top
Opic.Width = ws.Range(CellArr(ArCnt)).Width
Opic.Height = ws.Range(CellArr(ArCnt)).Height
ArCnt = ArCnt + 1
Next sFile
Set Opic = Nothing
Set SFolder = Nothing
Set FSO = Nothing
End Sub

 

[Megat91]

Hi Megat91. You can trial this code. HTH. Dave

Sub InsertPictures()
Dim SFolder As Object, FSO As Object, Opic As Object
Dim sFile As Object, CellArr As Variant
Dim ws As Worksheet, ArCnt As Integer
Set ws = ActiveSheet ' or a specific sheet
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SFolder = FSO.GetFolder("C:\Users\User\Pictures\")   '<----- Where the pictures are. Change as needed

CellArr = Array("D11", "J11", "P11", "V11", "AB11", "D19", "J19", "P19", "V19", _
                  "AB19", "D27", "J27", "P27", "V27", "AB27", "D35", "J35", "P35", _
                     "V35", "AB35", "D43", "J43", "P43", "V43", "AB43", "D51", "J51", "P51", "V51", "AB51")
ArCnt = 0
For Each sFile In SFolder.Files
Set Opic = Application.ActiveSheet.Shapes.AddPicture(SFolder.Path & "\" & sFile.Name, False, True, 1, 1, 1, 1)
Opic.Left = ws.Range(CellArr(ArCnt)).Left
Opic.Top = ws.Range(CellArr(ArCnt)).Top
Opic.Width = ws.Range(CellArr(ArCnt)).Width
Opic.Height = ws.Range(CellArr(ArCnt)).Height
ArCnt = ArCnt + 1
Next sFile
Set Opic = Nothing
Set SFolder = Nothing
Set FSO = Nothing
End Sub

it work as per expected, but the picture dont fit into the cell nicely

for example like below

 

[NdNoviceHlp]

They fit into the cell nicely but they don't fit into whatever those enlarged square things are? If you made your actual cells larger by moving the columns and row widths then they would still fit and be larger. I really don't know what those enlarged square things are that are superimposed over the cells? Dave

 

[Megat91]

They fit into the cell nicely but they don't fit into whatever those enlarged square things are? If you made your actual cells larger by moving the columns and row widths then they would still fit and be larger. I really don't know what those enlarged square things are that are superimposed over the cells? Dave

i guess it is because the cell e.g D11 is a merge cell (from D11 to H11, down to D17 to H17, the code given only fit the import picture to a single D11 cell size, it doesnt fit into the merge cell refer as D11 as mention earlier. Hence why you see all the square thing in the picture is big, it is due to the merge cell

 

[NdNoviceHlp]

Megat91 it seems according to the kind coders at the following link, that this code should fit the pictures in the merged cells. Good luck with this untested code. Dave

https://stackoverflow.com/questions/47069675/inserting-picture-using-macro-vba-to-adopt-to-a-merged-cell-or-single-cell

Sub InsertPictures()
Dim SFolder As Object, FSO As Object, Opic As Object
Dim sFile As Object, CellArr As Variant
Dim ws As Worksheet, ArCnt As Integer, r As Range, sel As Shape
Set ws = ActiveSheet ' or a specific sheet
Set FSO = CreateObject("Scripting.FileSystemObject")
'Set SFolder = FSO.GetFolder("C:\Users\User\Pictures\")   '<----- Where the pictures are. Change as needed
Set SFolder = FSO.GetFolder("C:\testfolder\")   '<----- Where the pictures are. Change as needed

CellArr = Array("D11", "J11", "P11", "V11", "AB11", "D19", "J19", "P19", "V19", _
                  "AB19", "D27", "J27", "P27", "V27", "AB27", "D35", "J35", "P35", _
                     "V35", "AB35", "D43", "J43", "P43", "V43", "AB43", "D51", "J51", "P51", "V51", "AB51")
ArCnt = 0

For Each sFile In SFolder.Files
Set Opic = Application.ActiveSheet.Shapes.AddPicture(SFolder.Path & "\" & sFile.Name, False, True, 1, 1, 1, 1)
With Opic
.Left = ws.Range(CellArr(ArCnt)).Left
.Top = ws.Range(CellArr(ArCnt)).Top
.Width = ws.Range(CellArr(ArCnt)).Width
.Height = ws.Range(CellArr(ArCnt)).Height
.Placement = xlMoveAndSize

Set r = Range(.TopLeftCell.MergeArea.Address)
Select Case (r.Width / r.Height) / (.Width / .Height)
Case Is > 1
    .Height = r.Height * 0.9
Case Else
    .Width = r.Width * 0.9
End Select

'center picture
.Top = r.Top + (r.Height - .Height) / 2
.Left = r.Left + (r.Width - .Width) / 2

End With
ArCnt = ArCnt + 1
Next sFile

Set Opic = Nothing
Set SFolder = Nothing
Set FSO = Nothing
End Sub

 

[NdNoviceHlp]

Grrr... Missed the edit. You will need to correct your folder address as I forgot to remove my testfolder location. Dave

 

[JBar97]

Hi Dave, just wanted to follow up on this thread.

I've tried utilising your code to create a photo log template which can automatically place a specified folder full of photos in set cells

As you can see the cells I wish to place the pictures into a merged - and using your code, set the cell array to the originating cell reference e.g. A6

But the pictures import very oddly as can be seen below.

Would you be able to assist in anyway? I have tried to insert the images as "Insert in Cell" but cannot figure a way how to do so.

Cheers, JB

 

[NdNoviceHlp]

Hi *Jbar97 and Welcome to the Board! This thread is somewhat aged and usually a new thread is recommended for a new question. It's not clear to me where you want your pictures or if your cells are merged? I suspect that you want them in those large white blank areas ie. "A6:I24", "J6:R24", "S6:AA24". You can trial this code for the first 3 ranges (if I'm right). You will need to adjust the folder path and ranges to suit. HTH. Dave

Sub InsertPictures()
Dim SFolder As Object, FSO As Object, Opic As Object
Dim sFile As Object, RngArr As Variant
Dim ws As Worksheet, ArCnt As Integer
Set ws = ActiveSheet ' or a specific sheet
Set FSO = CreateObject("Scripting.FileSystemObject")
'*** Folder path Change as needed
Set SFolder = FSO.GetFolder("C:\testfolder\")
'*** rngs for pics Change as needed
RngArr = Array("A6:I24", "J6:R24", "S6:AA24")
ArCnt = 0
On Error GoTo ErFix
For Each sFile In SFolder.Files
Set Opic = Application.ActiveSheet.Shapes.AddPicture(SFolder.Path & "\" & sFile.Name, False, True, 1, 1, 1, 1)
With Opic
.Left = ws.Range(RngArr(ArCnt)).Left
.Top = ws.Range(RngArr(ArCnt)).Top
.Width = ws.Range(RngArr(ArCnt)).Width
.Height = ws.Range(RngArr(ArCnt)).Height
.Placement = xlMoveAndSize
End With
ArCnt = ArCnt + 1
If ArCnt > UBound(RngArr) Then
GoTo ErFix
End If
Next sFile

ErFix:
If Err.Number <> 0 Then
MsgBox "Error"
End If
Set Opic = Nothing
Set SFolder = Nothing
Set FSO = Nothing
End Sub