PowerPoint VBA aligning grid of shapes into rows

Question

I have 6 shapes in a grid of 3x2. With their 'shape number' in the textbox as their respective z-order:

I currently have a code from another thread that rearranges the z-order of shapes from top to bottom, left to right:

Function orderShapes(shapeRange) As shape()
    'Adds selected shapes into an array from top to bottom, left to right
    If shapeRange.Count = 0 Then Exit Function
    
    ' Fill an array with all shapes.

    ReDim shapeArray(1 To shapeRange.Count) As shape
    Dim i As Long, j As Long
    For i = 1 To shapeRange.Count
        Set shapeArray(i) = shapeRange(i)
    Next
    
    ' Sort by position (left/top).
    For i = 1 To UBound(shapeArray) - 1
        For j = i To UBound(shapeArray)
            Dim left1 As Double, left2 As Double, top1 As Double, top2 As Double
            left1 = Round(shapeArray(i).Left, 1)
            left2 = Round(shapeArray(j).Left, 1)
            top1 = Round(shapeArray(i).Top, 1)
            top2 = Round(shapeArray(j).Top, 1)
            If top1 > top2 Or (top1 = top2 And left1 > left2) Then
                Dim tmpShape1 As shape
                Set tmpShape = shapeArray(i)
                Set shapeArray(i) = shapeArray(j)
                Set shapeArray(j) = tmpShape
            End If
        Next
    Next

    orderShapes = shapeArray
End Function

Sub setZOrderOfShapes()
    ' Rearranges the z-oarder of the shape array 
    Dim a() As shape, i As Long
    a = orderShapes(ActiveWindow.Selection.shapeRange)
    
    For i = 1 To UBound(a)
        a(i).ZOrder msoBringToFront
    Next
End Sub

The code above works as intended in two scenarios; shapes are already aligned top for each row (as the 'top1 = top2 And left1 > left2' condition will execute to determine the order) or if each shape in each row has a higher x-position to the shape to the right, like:

Is there a way to introduce a way to align the first row's shapes to top using .align msoAlignTops, and then doing the same for the second row of shapes and so on such that they look like:

I am unbale to get the function to loop through the first row (first three shapes), and then the next row (next three shapes) etc.

Answer 1

I'm sure there's a cleverer way of doing it but this seems to work:

Sub Tester()
    Dim colShapes As New Collection, shp As Shape
    'collect all shapes and pass them to `AlignShapesInRows` 
    For Each shp In ActivePresentation.Slides(1).Shapes
        colShapes.Add shp
    Next shp
    AlignShapesInRows colShapes
End Sub

Sub AlignShapesInRows(colShapes As Collection)
    Dim shp As Shape, col As New Collection, s2 As Shape, i As Long
    Dim st As Long, sb As Long, s2t As Long, s2b As Long
    
    Do While colShapes.Count > 0
        Set col = New Collection
        Set shp = colShapes(1)     'grab the first shape as a reference
        colShapes.Remove 1         '...and remove it from the original collection
        col.Add shp                'start a collection of "same row" shapes
        st = shp.Top               'vertical position to compare against
        sb = st + shp.Height
        For i = colShapes.Count To 1 Step -1  'check all remaining shapes
            Set s2 = colShapes(i)
            s2t = s2.Top
            s2b = s2t + s2.Height
            'any vertical overlap between the two shapes?
            If (s2t > st And s2t < sb) Or (s2b > st And s2b < sb) Then
                colShapes.Remove i  'remove from original collection
                col.Add s2           'add to "same row" collection
            End If
        Next i
        If col.Count > 1 Then  'if >1 shape then align all tops to top of first one
            For i = 2 To col.Count
                col(i).Top = col(1).Top
            Next i
        End If
    Loop
End Sub

Answer 2

The provided code was only tested for the simple scenario in the original post. It would need to be updated to handle more complex use cases.

Sub demo()
    Dim Shp As Shape
    Dim aShp(1 To 2, 1 To 3)
    Dim aTop(1 To 2) As Single
    Dim i As Integer, iIdx As Integer, iGroup As Integer
    ' Initial array to keep Top of group
    For i = 1 To 2
        aTop(i) = 99999
    Next
    Set oSlide = ActivePresentation.Slides(1)
    ' Loop through shapes
    For i = 1 To oSlide.Shapes.Count
        ' Get group id and index id
        iGroup = (i - 1) \ 3 + 1
        iIdx = i - (iGroup - 1) * 3
        Set aShp(iGroup, iIdx) = oSlide.Shapes(i)
        ' Get the hightest shape's Top
        If aTop(iGroup) > oSlide.Shapes(i).Top Then
            aTop(iGroup) = oSlide.Shapes(i).Top
        End If
    Next
    ' Align to top
    For iGroup = 1 To 2
        For iIdx = 1 To 3
            aShp(iGroup, iIdx).Top = aTop(iGroup)
        Next
    Next iGroup
End Sub

Answer 3

(1) I have reworked the routine that sorts the shapes: I added a parameter to sort either from top to bottom or from left to right. And it returns no longer an Array but a Collection of Shapes. Again, the result can be used for anything, for setting the text of the shapes, the z-Order, the position...

I have borrowed the logic how to sort a Collection from https://stackoverflow.com/a/3588073/7599798 As one of the commenters raged against BubbleSort: The collections will never be large, BubbleSort is perfectly fine.

Function orderShapes(shapeRange, Optional orderFromTop As Boolean = True) As Collection
    ' shapeRange can be either of type ShapeRange or of type Shapes, or it can be a collection of shapes
    ' Fill an array with all shapes.

    If shapeRange.Count = 0 Then Exit Function
    Dim shapes As New Collection, i As Long, j As Long
    For i = 1 To shapeRange.Count
        shapes.Add shapeRange(i)
    Next

    ' Sort by position (left/top).
    For i = 1 To shapes.Count - 1
        For j = i To shapes.Count - 1
            Dim left1 As Double, left2 As Double, top1 As Double, top2 As Double
            left1 = Round(shapes(i).Left, 1)
            top1 = Round(shapes(i).Top, 1)
            left2 = Round(shapes(j).Left, 1)
            top2 = Round(shapes(j).Top, 1)
            
            If (orderFromTop And (top1 > top2 Or (top1 = top2 And left1 > left2))) _
            Or (Not orderFromTop And (left1 > left2 Or (left1 = left2 And top1 > top2))) Then
                Dim tmpShape As Shape
                Set tmpShape = shapes(j)
                shapes.Remove j
                shapes.Add tmpShape, , i
            End If
        Next
    Next
    
    Set orderShapes = shapes
End Function

(2) Now arranging shapes is not that hard, we can do this by setting the Left and Top properties of the shapes. What we need is to:

Sort the shapes by their top position using the sort routine. With that, we can identify the shapes that belong in the same row of the grid.

Loop over the sorted shapes, put every n (=number of shapes per row) shapes into a collection and sort this from left to right - so that for example shape 2 of your original image stays in column 2 even if it is higher than shape 1.

Note that the whole logic doesn't need to set any z-Order.

Sub ArrangeShapes(shapeRange, numberOfCols As Long, colWidth As Double, rowHeight As Double)
    
    Dim allShapes As Collection
    Set allShapes = orderShapes(shapeRange, orderFromTop:=True) ' Sort from top to bottom
    
    Dim col As Long, row As Long, startX As Double, startY As Double
    row = 1
    Do While True
        Dim firstRowShape As Long, rowShapeCount As Long
        firstRowShape = (row - 1) * numberOfCols + 1          ' First shape for this row
        If firstRowShape > allShapes.Count Then Exit Do       ' No shape left -> We are done.
        
        rowShapeCount = allShapes.Count - firstRowShape + 1   ' Number of shapes for this row
        If rowShapeCount > numberOfCols Then rowShapeCount = numberOfCols
    
        ' Put all Shapes for this row into a new Collection
        Dim tmpShapes As Collection
        Set tmpShapes = New Collection
        Dim i As Long
        For i = 1 To rowShapeCount
            tmpShapes.Add allShapes(firstRowShape + i - 1)
        Next i
        
        ' Sort the shapes of one row from left to right
        Dim rowShapes As Collection
        Set rowShapes = orderShapes(tmpShapes, orderFromTop:=False) ' Sort from left to right
            
        ' Position the shapes of this row
        If row = 1 Then
            startX = rowShapes(1).Left
            startY = rowShapes(1).Top
        End If
        
        For col = 1 To rowShapeCount
            rowShapes(col).Left = startX + (col - 1) * colWidth
            rowShapes(col).Top = startY + (row - 1) * rowHeight
            rowShapes(col).TextFrame.TextRange.Text = row & " / " & col
        Next
                
        row = row + 1
    Loop
End Sub

A test that arranges all shapes of a slide:

Sub test1()
    ArrangeShapes ActivePresentation.Slides(1).shapes, 3, 80, 60
End Sub

Or only selected shapes:

Sub TestSelection()
    ArrangeShapes ActiveWindow.Selection.shapeRange, 3, 80, 60
End Sub