VBA macro to Insert images into a grid pattern in excel worksheet. [2 columns, unlimited rows, empty cell in-between]

[Phenotype]

Hi,


I've tried multiple macros on the internet that get very close to what I need but just need a few tweaks I'm unable to figure out.

I need a macro that can insert photos from a folder into a grid pattern into an excel worksheet.

The grid would be 2 columns across by an unlimited number of rows. Ideally, in the cell directly below each photo there would be an empty cell for a short caption.

Furthermore, the photos need to be in order, that is: Image 1 in A1, Image 2 in B1, Image 3 in A3, Image 4 in B3 (until the source folder is empty). I'd like to fit in 6 decently sized images per page.

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

The macro in the above thread manages to insert images in a 3 column, unlimited row format with an empty cell to enter a comment but not in order I need!

Our IT specialist is away on holidays so I spent a solid day failing miserably at solving this so any help will be greatly appreciated!


Cheers,
Phenotype.

 

[Perpa]

Robyn,

Now I understand why the previous pictures and picture filenames were not deleted when you ran the macro on the second folder. The following code was skipped due to the single quotes before each line...

    'ActiveCell.Select
    'Clear Sheet1
    'ActiveSheet.UsedRange.ClearContents
    'For Each sh In Sheets("Sheet1").Shapes
    '   sh.Delete
    'Next sh

Change the above to the following (remove single quote from last 4 lines):

    'ActiveCell.Select - you probably don't need this line, but leave the single quote for now
    'Clear Sheet1 - This is a comment line, leave the single quote

    ActiveSheet.UsedRange.ClearContents
    For Each sh In Sheets("Sheet1").Shapes
       sh.Delete
    Next sh

With those changes, you may want to try the 'non-code' accumulation method I mentioned earlier:

Run the macro on each folder (Path) then copy each result to a Master Worksheet.
You could then insert additional rows for Showing the Facility Name and any other info you wish to add for that location.

I noticed you added a line of code, although I did not see where you use the 'ac' variable?:

     ac = ActiveCell.Row

Maybe you could explain what you were going to do with that row variable.


I don't have time to look at automating the Master Worksheet to accumulate multiple folder images at the moment. I have another project I am currently working on. Perhaps someone else maybe able to help you with that. It would be best if you started a new thread with that goal, and reference this thread for backup.
Good luck.
Perpa

 

[Perpa]

Robyn,
Here is some revised code I have been thinking about. I removed the code to clear Sheet1, and added some code to insert rows at the top of Sheet1.
New pictures are added to the top. Folders must be entered in reverse order... Therefore, if you want a certain folder's pictures to be shown at the top of Sheet1, then you would run the macro on that folder last.

I also added a separate macro you can use to clear the pictures from Sheet1, 'ClrSheetofPics'.
I hope this will work for you.
Perpa

Sub AddOlEObject_2x3Rev()
    Dim mainWorkBook As Workbook
    Dim counter, rw, LR, ac As Long
    Dim RowsOfPics 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


    '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

    RowsOfPics = NoOfFiles / 3
        If RowsOfPics - Int(RowsOfPics) <> 0 Then
            RowsOfPics = (RowsOfPics + 1) * 4
        Else
            RowsOfPics = (RowsOfPics) * 4
        End If
   
    Rows("1:" & RowsOfPics).insert shift:=xlDown

    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
    'ac = ActiveCell.Row
    For rw = 1 To LR Step 3
        Sheets("Sheet1").Range("B" & rw + 1).Value = Sheets("Sheet2").Range("I" & rw).Value
        Sheets("Sheet1").Range("B" & rw + 1).RowHeight = 16
        'Sheets("Sheet1").Range("B" & rw).ColumnWidth = 50     'Adjust COLUMNS to fit your pictures
        Sheets("Sheet1").Range("B" & rw).RowHeight = 220       'Adjust ROWS to fit your pictures
        Call insert1(Sheets("Sheet2").Range("A" & rw).Value, rw)
    Next rw
    
    For rw = 1 To LR Step 3
        Sheets("Sheet1").Range("E" & rw + 1).Value = Sheets("Sheet2").Range("I" & rw + 1).Value
        'Sheets("Sheet1").Range("E" & rw).ColumnWidth = 50     'Adjust COLUMNS to fit your pictures
        Call insert2(Sheets("Sheet2").Range("A" & rw + 1).Value, rw)
    Next rw
 
    For rw = 1 To LR Step 3
       Sheets("Sheet1").Range("M" & rw + 1).Value = Sheets("Sheet2").Range("I" & rw + 2).Value
       'Sheets("Sheet1").Range("M" & rw).ColumnWidth = 50     'Adjust COLUMNS to fit your pictures
       Call insert3(Sheets("Sheet2").Range("A" & rw + 2).Value, rw)
    Next rw
 
 Sheets("Sheet1").Activate
Application.ScreenUpdating = True
End Sub

Sub ClrSheetofPics()
    Sheets("Sheet1").Activate    'Change the sheet name from "Sheet1" to the sheet name where you want your pictures to go
    
    'Cleanoff Sheet1
    ActiveSheet.UsedRange.ClearContents
    For Each sh In Sheets("Sheet1").Shapes
       sh.Delete
    Next sh
End Sub

 

[RChapman9]

Perpa,

Thank you so much for the additional code!! My needs have changed slightly, so I'm going to start a new thread as you suggested.

Thank you again for your wonderful assistance!!

Best regards,
Robyn

 

[Perpa]

Robyn,
I was glad to be of help and you are welcome. Since your needs have changed it is best that you start a new thread as you intend to do. I wish you well.
Perpa