Placing pictures into a grid

[Dr. Demento]

I've got a number of pictures already copied into a sheet and I'd like to arrange them (withOUT resizing the picture) into a grid pattern. This needs to take into consideration the max number of pictures I designate that will be in any particular column AND space the pictures out based on how many rows/columns they occupy. I've cobbled some code together but I'm no where near where I want it to be.

I realize I may be barking up various wrong trees but I'm too frustrated to see a way forward.

Any pointers would be greatly appreciated.

Thanks, y'all!

Sub pic_GRID()

Dim wbk As Workbook
  Set wbk = ActiveWorkbook
Dim sht As Worksheet
  Set sht = ActiveSheet

Dim shp As Shape

Dim rng As Range, rng0 As Range
  Set rng0 = sht.Range("A1")

Dim down As Long, across As Long, _
    rw As Long, col As Long, _
    cntr As Long

Const maxPics As Long = 5
Const pxconv As Long = 96
Const rwHt As Double = 16.5
Const colWd As Double = 8.11


  For Each shp In sht.Shapes
    cntr = cntr + 1
' My attempt to have a counter that limits the number of pictures down = maxPics; once the down variable hits maxPics, it resets to top line and moves one across
    down = ((cntr - 1) Mod maxPics)
    across = Int((cntr - 1) / maxPics)
    

    ' I'm attempting to place each picture using a cell as a reference
    
    Set rng = rng0.offset(rw * down, _
                         (col * across)).Resize(1, 1)
Debug.Print down & "|" & across & "|" & shp.Width & "|"& shp.Height & "|"& rng.Address

    With shp  ' I have no idea how to correct this.  For the first picture, it should be placed in A1; the second picture (213px) should be placed in A16
      .Left = sht.Cells(rng.Column).Left  '
      .Top = sht.Cells(rng.Row).Top
    End With

    rw = rw + WorksheetFunction.RoundUp(shp.Height / rwHt, 0) + 2  ' This gives the proper number of rows that a picture takes plus a row or two as spacer but it doesn't place it properly given my problem with shp.top & shp.left above
    col = across * WorksheetFunction.max(col, WorksheetFunction.RoundUp(shp.Width / colWd, 0))  ' I have no idea what's going wrong here; I'm trying to find the next column to be populated based on the widest picture so far.

  Next shp

End Sub

 

[Jimmypop]

Hi there...

Untested but maybe the below could assist?

1. Consider using a separate loop to calculate the number of rows and columns needed for the grid, based on the number of pictures and the maximum number of pictures in a column. This will make it easier to reference the correct cells when positioning the pictures. Here's an example of how this loop might look:

Dim numPics As Long
Dim numRows As Long
Dim numCols As Long

numPics = sht.Shapes.Count
numCols = WorksheetFunction.Min(maxPics, numPics)
numRows = WorksheetFunction.Ceiling(numPics / numCols, 1)

1. When positioning the pictures, you can use the Left and Top properties of the cell that the picture should be anchored to, instead of using the Left and Top properties of the picture itself. Here's an example of how this might look:

shp.Left = rng.Left + (rng.Width - shp.Width) / 2
shp.Top = rng.Top + (rng.Height - shp.Height) / 2

This code centers the picture horizontally and vertically within the cell, based on the difference between the cell width/height and the picture width/height.

1. When calculating the next column to be populated, you should add the width of the widest picture so far to the current column index, instead of multiplying them together. Here's an example of how this might look:

col = col + WorksheetFunction.Max(WorksheetFunction.RoundUp(shp.Width / colWd, 0), 1)

This code adds the width of the picture (in column units) to the current column index, and rounds up to the nearest integer if necessary. It also ensures that the minimum column increment is 1, to prevent a zero or negative value.

I hope these suggestions help you to make progress on your code!

 

[Dr. Demento]

That absolutely got me on the proper track. I can't thank you enough!!

I still couldn't get the size of the picture to match with the column width; it just won't jive. I had to just guesstimate using trial and error. I'd like to understand why the math doesn't work but not sure it's worth the effort.

Thanks again, Jimmypop!

Here's the code, in case anyone else is interested.

Sub pic_GRID()
' https://www.mrexcel.com/board/threads/create-macro-to-insert-photos-into-excel-grid.897485/

Dim wbk As Workbook
  Set wbk = ActiveWorkbook
Dim sht As Worksheet
  Set sht = ActiveSheet

Dim shp As Shape

Dim rng As Range, rng0 As Range
  Set rng0 = sht.Range("G1")

Dim cntrR As Long, cntrC As Long, _
    posnR As Long, posnC As Long, _
    cntr As Long

Const pxconv As Long = 96
Const rwHt As Double = 16.5
Const colWd As Double = 8.11

Dim widthC As Long

Dim numPics As Long
Dim numRows As Long
Dim numCols As Long
  numPics = shpCount(sht, msoPicture)
  numCols = WorksheetFunction.min(maxPics, numPics)
  numRows = WorksheetFunction.Ceiling(numPics / numCols, 1)

  For cntrC = 1 To numCols
    For cntrR = 1 To numRows
      
      cntr = cntr + 1
      If cntr > numPics Then _
        Exit Sub
      
      Set shp = sht.Shapes(cntr)
      Set rng = rng0.offset(posnR, posnC).Resize(1, 1)

      With shp
        .Left = rng.Left
        .Top = rng.Top
      End With

      posnR = rng.Row + WorksheetFunction.RoundUp(shp.Height / rwHt, 0) + 2
      widthC = WorksheetFunction.max(WorksheetFunction.RoundUp(shp.Width / pxconv, 0) + 3, widthC, 1)
    Next cntrR
    
    posnC = posnC + widthC
    posnR = 0: widthC = 0
  
  Next cntrC

End Sub

 

[Jimmypop]

Hi Dr. Demento... glad we could help and assist, thanks for the feedback . Also not sure what would be the issue with the size and column width