The macro which is the closest to what I need can be found at the bottom of this thread (posted by Perpa):
http://www.mrexcel.com/forum/excel-questions/897485-create-macro-insert-photos-into-excel-grid.html
QUOTE]
Phenotype,
This proceedure uses both Sheet1 and Sheet2. Sheet1 is the picture display sheet, Sheet 2 is used to sort the filename list. You will have to adjust your margins TOP and BOTTOM to achieve the layout you want. I held the picture HEIGHT to maintain the aspect ratio of the original image in both Functions. You can hold both HEIGHT and WIDTH but there maybe some distortion.
There are two code snippets, one to sort the filenames, the other to place the pictures using the 2 Functions.
Before running the code below, this formula must be copied into Sheet2 cell I1:
' =TRIM(RIGHT(SUBSTITUTE(A1,"",REPT(" ",50)),50))'
The formula separates the filename from the complete file path which is in Column A. The filename is used below each picture on Sheet1.
Happy Holidays!
Perpa
Code:
Sub AddOlEObject_2x3()
Dim mainWorkBook As Workbook
Dim counter, rw, LR 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 to go
'Clear Sheet1
ActiveSheet.UsedRange.ClearContents
For Each sh In Sheets("Sheet1").Shapes
sh.Delete
Next sh
'Change the folderpath to wherever your pictures are coming from
Folderpath = InputBox("Enter the complete folder path to you 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
rw = 1
For Each fls In listfiles
Sheets("Sheet2").Range("A" & rw).Value = fls
rw = rw + 1
Next fls
Call SortMyFiles
LR = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
For rw = 1 To LR Step 2
Sheets("Sheet1").Range("A" & rw + 1).Value = Sheets("Sheet2").Range("I" & rw).Value
Sheets("Sheet1").Range("A" & rw + 1).RowHeight = 16
Sheets("Sheet1").Range("A" & rw).ColumnWidth = 50 'Adjust COLUMNS to fit your pictures
Sheets("Sheet1").Range("A" & rw).RowHeight = 200 'Adjust ROWS to fit your pictures
Call insert1(Sheets("Sheet2").Range("A" & rw).Value, rw)
Next rw
For rw = 1 To LR Step 2
Sheets("Sheet1").Range("B" & rw + 1).Value = Sheets("Sheet2").Range("I" & rw + 1).Value
Sheets("Sheet1").Range("B" & rw).ColumnWidth = 50 'Adjust COLUMNS to fit your pictures
Call insert2(Sheets("Sheet2").Range("A" & rw + 1).Value, rw)
Next rw
Sheets("Sheet1").Activate
Application.ScreenUpdating = True
End Sub
Sub SortMyFiles()
Dim LR, rw As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet2").Select
Range("A1:A" & LR).Select
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet2").Sort
.SetRange Range("A1:A" & LR)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With Sheets("Sheet2")
.Activate
LR = .Range("A" & Rows.Count).End(xlUp).Row
For rw = 2 To LR
'Copies formula
.Range("I1").Copy 'This is the formula to find the filename
.Range("I" & rw).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Next rw
End With
Range("A" & LR + 1).Activate
Sheets("Sheet1").Activate
End Sub
Function insert1(PicPath, counter1)
'Formats Column A Pictures
With ActiveSheet.Pictures.insert(PicPath)
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 = 198 'Adjust to change the HEIGHT of your pictures
End With
.Left = ActiveSheet.Range("A" & counter1).Left
.Top = ActiveSheet.Range("A" & counter1).Top
.Placement = 1
.PrintObject = True
End With
End Function
Function insert2(PicPath, counter2)
'Formats Column B Pictures
With ActiveSheet.Pictures.insert(PicPath)
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 with the single quote
.Height = 198 'Adjust to change the HEIGHT of your pictures
End With
.Left = ActiveSheet.Range("B" & counter2).Left
.Top = ActiveSheet.Range("B" & counter2).Top
.Placement = 1
.PrintObject = True
End With
End Function
