VBA to insert images in a grid pattern

[RChapman9]

A wonderful forum member (Perpa) helped me modify some code he posted to insert images in rows of 3 in a spreadsheet. He suggested I start a new thread for further modifications.

The macro works very well to insert images in a fresh sheet; however, I need to designate the starting point. For example, if I have data in the sheet from A1:N200, I need the images to start at B:205. Running this macro always inserts the images beginning in row 1. Can anyone help with a modification to start at the active cell or designate a starting cell?

Thanks so much!!
Robyn

https://www.mrexcel.com/forum/excel...olumns-unlimited-rows-empty-cell-between.html

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("Sheet2").Select
    Columns("A:A").Select
    Selection.ClearContents
    Range("I2:I100").Select
    Selection.ClearContents

    Sheets("Write-up").Activate    'Change the sheet name from "Write-up" 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("Write-up").Range("B" & rw + 1).Value = Sheets("Sheet2").Range("I" & rw).Value
        Sheets("Write-up").Range("B" & rw + 1).RowHeight = 16
        'Sheets("Write-up").Range("B" & rw).ColumnWidth = 50     'Adjust COLUMNS to fit your pictures
        Sheets("Write-up").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("Write-up").Range("E" & rw + 1).Value = Sheets("Sheet2").Range("I" & rw + 1).Value
        'Sheets("Write-up").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("Write-up").Range("M" & rw + 1).Value = Sheets("Sheet2").Range("I" & rw + 2).Value
       'Sheets("Write-up").Range("M" & rw).ColumnWidth = 50     'Adjust COLUMNS to fit your pictures
       Call insert3(Sheets("Sheet2").Range("A" & rw + 2).Value, rw)
    Next rw

 Sheets("Write-up").Activate
Application.ScreenUpdating = True


    Sheets("Master").Select
    Range("A1").Select


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("Write-up").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 = 215    'Adjust to change the HEIGHT of your pictures
        End With
        .Left = ActiveSheet.Range("B" & counter1).Left
        .Top = ActiveSheet.Range("B" & counter1).Top
        .Placement = 1
        .PrintObject = True
    End With
    ActiveCell.Offset(1, 0).Select

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 = 215    'Adjust to change the HEIGHT of your pictures
        End With
        .Left = ActiveSheet.Range("E" & counter2).Left
        .Top = ActiveSheet.Range("E" & counter2).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function




Function insert3(PicPath, counter3)
'Formats Column C 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 = 215    'Adjust to change the HEIGHT of your pictures
        End With
        .Left = ActiveSheet.Range("M" & counter3).Left
        .Top = ActiveSheet.Range("M" & counter3).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function

 

[RChapman9]

Hope it's okay to bump this. This is the last piece of a 3+ week project. It seems like it should be a simple fix, but nothing I've tried so far has worked.

Thanks in advance for any assistance!

Robyn

 

[Perpa]

Robyn,
I saw this second post and had a thought...maybe this modification is just this simple...
To designate the row where the pictures will start, you can use 'Activecell.row' with a tweak...
Assuming you select cell A205 on your sheet 'Write-up',

Change this line:

'ac = ActiveCell.Row

to this:

ac = Sheets("Write-up").ActiveCell.Row-1      'without the single quote

Then change these three lines in the 'For/Next' loops:

Call insert1(Sheets("Sheet2").Range("A" & rw).Value, rw)
.
.
.
Call insert2(Sheets("Sheet2").Range("A" & rw + 1).Value, rw)
.
.
.
Call insert3(Sheets("Sheet2").Range("A" & rw + 2).Value, rw)

To these:

Call insert1(Sheets("Sheet2").Range("A" & rw).Value, rw+ac)
.
.
.
Call insert2(Sheets("Sheet2").Range("A" & rw + 1).Value, rw+ac)
.
.
.
Call insert3(Sheets("Sheet2").Range("A" & rw + 2).Value, rw+ac)

Let's see if that does what you want.
Perpa

 

[RChapman9]

Hi, Perpa!

This didn't work, unfortunately, but it helped me understand the code a bit better. I'm going to play around with it some more and see if I can adapt this approach. I will let you know if I manage to work it out.

Thanks again!! Your assistance has been invaluable!!

Best regards,
Robyn

 

[Perpa]

Robyn,
I finished my other job and had time to look at your 'row selection for inserting pictures' code again. I tried it last night and it worked flawlessly. I made those same changes to your most recent posting.

I did notice a couple of things in your most recent code:
- you changed the worksheet name to 'Write-up' from 'Sheet1' - no problem there.
- you were activating another sheet 'Master' at the end of the code - I commented that out and had the screen show the top of the newly added pictures on sheet 'Write-up' - change that back if you need to.
- I moved the line of code 'ac = ActiveCell.Row-1' to above the 'For/Next' statement because placement of the pictures is always dependant on that starting row.

The rest of the code, 'SortMyFiles', and the 3 Functions leave as you have them in your post# 1.
Give it a try and let me know the results.
Perpa

Sub AddOlEObject_Rev2()
    Dim mainWorkBook As Workbook
    Dim ac, counter, LR, rw, As Long

    Application.ScreenUpdating = False
    Set mainWorkBook = ActiveWorkbook

    Sheets("Write-up").Activate    'Change the sheet name from "Write-up" 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
    ac = ActiveCell.Row-1

    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 3
        Sheets("Write-up").Range("B" & rw + ac + 1).Value = Sheets("Sheet2").Range("I" & rw).Value
        Sheets("Write-up").Range("B" & rw + ac  + 1).RowHeight = 16
        'Sheets("Write-up").Range("B" & rw + ac ).ColumnWidth = 50     'Adjust COLUMNS to fit your pictures
        Sheets("Write-up").Range("B" & rw + ac ).RowHeight = 220       'Adjust ROWS to fit your pictures
        Call insert1(Sheets("Sheet2").Range("A" & rw).Value, rw + ac )
    Next rw

    For rw = 1 To LR Step 3
        Sheets("Write-up").Range("E" & rw + ac  + 1).Value = Sheets("Sheet2").Range("I" & rw + 1).Value
        'Sheets("Write-up").Range("E" & rw + ac ).ColumnWidth = 50     'Adjust COLUMNS to fit your pictures
        Call insert2(Sheets("Sheet2").Range("A" & rw + 1).Value, rw + ac )
    Next rw

    For rw = 1 To LR Step 3
       Sheets("Write-up").Range("M" & rw + ac  + 1).Value = Sheets("Sheet2").Range("I" & rw + 2).Value
       'Sheets("Write-up").Range("M" & rw + ac ).ColumnWidth = 50     'Adjust COLUMNS to fit your pictures
       Call insert3(Sheets("Sheet2").Range("A" & rw + 2).Value, rw + ac )
    Next rw

Sheets("Write-up").Activate
Application.ScreenUpdating = True

'Sheets("Master").Select     'Uncomment if this line is required
Range("A" & ac).Select         'Top of newly added pictures

End Sub