OK右にn個コピー

Sub CopyAndResizeShapes()

    Dim sld As Slide

    Dim origShp As Shape

    Dim newShp As Shape

    Dim count, i As Integer

    Dim h, newH, space, totalSpace As Single

    ' 現在のスライドを取得

    Set sld = Application.ActiveWindow.View.Slide

    ' 選択された図形を取得

    If Not sld.Shapes.Count = 0 Then

        Set origShp = Application.ActiveWindow.Selection.ShapeRange(1)

        ' 選択された図形の高さを取得

        h = origShp.Height

        ' ダイアログボックスで数を入力

        count = InputBox("いくつの長方形をコピーしますか?", "図形の数")

        ' 新しい長方形の高さと間隔を計算

        totalSpace = h / (3 * count + count - 1)

        newH = totalSpace * 3

        space = totalSpace

        ' 長方形をコピー・ペースト

        For i = 1 To count

            origShp.Copy

            Set newShp = sld.Shapes.Paste()(1)

            newShp.Height = newH

            newShp.Left = origShp.Left + origShp.Width

            newShp.Top = origShp.Top + (newH + space) * (i - 1)

        Next i

        ' 最後の長方形の下端を元の図形と合わせる

        newShp.Top = origShp.Top + origShp.Height - newShp.Height

    Else

        MsgBox "図形が選択されていません。"

    End If

End Sub