Align and distribute objects to grid in VBA?

How do I align and distribute a random bunch of objects like this:

To this:

Manually I can select the objects row by row, or column by column, and align center relative to object, then distribute evenly.

I'm trying to write a macro to do this in one-click, but am already stuck at the first step, identifying rows or columns of objects by position.

Is there any perhaps established way of doing this in VBA?

    • Thanks for replying. :) What I need though, is for the program to do this without specifying a fixed row and column count. I know how to lay the objects as a grid if the dimension is known. What I'm struggling is a way to detect the rows and columns. I suppose, something in the lines of "closest objects to the topmost object by y position" for rows, for example.

  • Sub DistributeXY()
        Dim s As Shape, SR As ShapeRange, X As Double, Y As Double, i%, j%, n%, kI%, kJ%

        Set SR = ActiveSelectionRange
        If Int(Sqr(SR.Count)) > Sqr(SR.Count) Then
            kI = Int(Sqr(SR.Count)) + 1
        Else
            kI = Int(Sqr(SR.Count))
        End If

        If kI * Round(SR.Count / kI, 0) < SR.Count Then
            kJ = Round(SR.Count / kI, 0) + 1
        Else
            kJ = Round(SR.Count / kI, 0)
        End If

        X = SR.LeftX
        Y = SR.TopY
        For i = 0 To kI - 1
            For j = 0 To kJ - 1
                n = n + 1
                If n > SR.Count Then Exit For
                SR(n).SetPositionEx cdrTopLeft, X, Y - j * (SR(1).SizeHeight + (SR.SizeHeight - SR(1).SizeHeight * kJ) / (kJ - 1))
            Next j
            X = X + (SR(1).SizeWidth + (SR.SizeWidth - SR(1).SizeWidth * kI) / (kI - 1))
        Next i
    End Sub


    In this macro, I have written in such a way that the number of rows and the number of columns are minimally different.
    For example, if you have 21 figures, this macro will spread them into a 6 * 4 matrix and 3 empty places will remain.
    It is obvious that it would be more optimal be arranged in 3 rows and 7 columns.
    For this example, I didn't set that as a goal.
    Wish you success.
    Taras

    • Thank you so much!! This works fantastic.

      If I may ask - it probably belongs to another topic - but what if we detect the rows by position instead of the approximation of the matrix from the number of objects? In practice, the objects would come in all shapes and sizes, so sometimes I may have a different number of objects in each row. I guess what I have in mind is more like paragraph justification rather than grid layout in this case.

    • Sub DistributeXY()
      Dim s As Shape, SR As ShapeRange, X As Double, Y As Double, i%, j%, n%, kI%, kJ%

      Set SR = ActiveSelectionRange
      If Int(Sqr(SR.Count)) > Sqr(SR.Count) Then
      kI = Int(Sqr(SR.Count)) + 1
      Else
      kI = Int(Sqr(SR.Count))
      End If

      If kI * Round(SR.Count / kI, 0) < SR.Count Then
      kJ = Round(SR.Count / kI, 0) + 1
      Else
      kJ = Round(SR.Count / kI, 0)
      End If

      X = SR.LeftX
      Y = SR.TopY
      For i = 0 To kI - 1
      For j = 0 To kJ - 1
      n = n + 1
      If n > SR.Count Then Exit For
      SR(n).SetPositionEx cdrTopLeft, X, Y - j * (SR(1).SizeHeight + (SR.SizeHeight - SR(1).SizeHeight * kJ) / (kJ - 1))
      Next j
      X = X + (SR(1).SizeWidth + (SR.SizeWidth - SR(1).SizeWidth * kI) / (kI - 1))
      Next i
      End Sub

      • I like it. I added the lines in bold

        Any way to make the spacing the same vertically & horizontally.

        Sub DistributeXY()
        Dim s As Shape, SR As ShapeRange, X As Double, Y As Double, i%, j%, n%, kI%, kJ%
        ActiveDocument.BeginCommandGroup "DistributeXY"
        Optimization = True
        Set SR = ActiveSelectionRange
        If Int(Sqr(SR.Count)) > Sqr(SR.Count) Then
        kI = Int(Sqr(SR.Count)) + 1
        Else
        kI = Int(Sqr(SR.Count))
        End If

        If kI * Round(SR.Count / kI, 0) < SR.Count Then
        kJ = Round(SR.Count / kI, 0) + 1
        Else
        kJ = Round(SR.Count / kI, 0)
        End If

        X = SR.LeftX
        Y = SR.TopY
        For i = 0 To kI - 1
        For j = 0 To kJ - 1
        n = n + 1
        If n > SR.Count Then Exit For
        SR(n).SetPositionEx cdrTopLeft, X, Y - j * (SR(1).SizeHeight + (SR.SizeHeight - SR(1).SizeHeight * kJ) / (kJ - 1))
        Next j
        X = X + (SR(1).SizeWidth + (SR.SizeWidth - SR(1).SizeWidth * kI) / (kI - 1))
        Next i
        Optimization = False
        ActiveWindow.Refresh
        ActiveDocument.EndCommandGroup
        End Sub