PowerPoint VBA 図形を等間隔に連続複製するマクロ

VBA・マクロ

2020.10.182024.02.24

PowerPoint VBAを使い、図形を指定の間隔を空けて連続複製するマクロをご紹介します。

通常、パワポではだいたいの間隔で図形を等間隔に並べます。（毎度グリッドの設定をするのも手間なので…）

でも、今日でだいたいの間隔とは卒業！

Illustratorのように間隔を指定して複製したい！

そんな願いが叶う「間隔を指定をして連続複製できるマクロ」を作りました。

複製時の空きが指定できると、グリッドの設定をしなくても水平方向と垂直方向の間隔を揃えて連続複製することができます。

この記事の目次

右に等間隔に複製するマクロ
1. コード
下に等間隔に複製するマクロ
1. コード
実行結果
マクロを連続で実行するには？

右に等間隔に複製するマクロ

コード

Sub 右に等間隔に複製()

    Dim msg As String
    Dim n As Long
    Dim spacing As Single
    
    'オブジェクトの間隔を「cm」で指定
    spacing = 0.5
    
    '間隔を「pt」に変換
    spacing = Round(spacing * 720 / 25.4, 1)

    '選択中のオブジェクトをコピー
    With ActiveWindow.Selection
    
        'オブジェクトが選択されていない場合はマクロ終了
        If .Type = ppSelectionNone _
        Or .Type = ppSelectionSlides Then
        
            msg = "オブジェクトを選択してください。"
            MsgBox msg
            Exit Sub
            
        End If
    
        With .ShapeRange
        
            'オブジェクトをコピー
            .Copy
            'コピー元の位置を代入
            x = .Top
            y = .Left
            'コピー元の幅を代入
            w = .Width
            
        End With
    End With
        
    '選択中のスライド番号を取得
    n = ActiveWindow.Selection.SlideRange.SlideIndex
    
    '右に空き0cmで複製
    With ActivePresentation.Slides(n).Shapes.Paste
    
        '複製先の位置
        .Top = x
        .Left = y + w + spacing
        '複製したオブジェクトを選択
        .Select
        
    End With
End Sub

「spacing」の値で複製時のオブジェクトの間隔を指定します。間隔を「0.5cm」空けて複製したい場合は「spacing = 0.5」にします。

下に等間隔に複製するマクロ

コード

Sub 下に等間隔に複製()

    Dim msg As String
    Dim n As Long
    Dim spacing As Single
    
    'オブジェクトの間隔を「cm」で指定
    spacing = 0.5
    
    '間隔を「cm」に変換
    spacing = Round(spacing * 720 / 25.4, 1)

    '選択中のオブジェクトをコピー
    With ActiveWindow.Selection
    
        'オブジェクトが選択されていない場合はマクロ終了
        If .Type = ppSelectionNone _
        Or .Type = ppSelectionSlides Then
        
            msg = "オブジェクトを選択してください。"
            MsgBox msg
            Exit Sub
            
        End If
    
        With .ShapeRange
        
            'オブジェクトをコピー
            .Copy
            'コピー元の位置を代入
            x = .Top
            y = .Left
            'コピー元の高さを代入
            h = .Height
            
        End With
    End With
        
    '選択中のスライド番号を取得
    n = ActiveWindow.Selection.SlideRange.SlideIndex
    
    '下に空き0cmで複製
    With ActivePresentation.Slides(n).Shapes.Paste
    
        '複製先の位置
        .Top = x + h + spacing
        .Left = y
        '複製したオブジェクトを選択
        .Select
        
    End With
End Sub