PowerPoint テキストや図形の位置LeftとTopをExcelシートへ シートの座標修正後に再度パワポに戻し位置を移動させる手順を解説

単純にシェイプの Shape.Leftと.Topを取得してシートに書き出す。
次に、逆のシートの値をパワポのShape.Leftと.Topにセットして、
移動っぽく処理しただけです。
大量テキストや図形の移動処理のヒントとなれば幸いです。
youtu.be
https://youtu.be/zYczLG7wF9E
目次
00:00 やりたいこと
01:25 1.テキストや図形の位置LeftとTopを取得
04:01 2.シートの値をShape.Leftと.Topにセット
09:43 3.コードの組み込み方法
10:12 3.1 取得コードを組み込む テストする
12:08 3.2 移動のコードを組み込む テストする
14:00 3.3 基準となるタイトル位置を決めます
14:44 3.4 Sheet1でデータを取得します
15:01 3.5 フィルターをかけ Title1を絞り込みます
15:34 3.6 タイトルのデータをコピーします
15:44 3.7 隣の移動用シートに貼り付けます
15:52 3.8 基準となる データをコピーします 3.9 マクロを走らせます
18:18 タイトル以外の違う項目を移動テストする
20:06 3.10 タイトルに規則性が無かったら？どうする？
24:05 4.蛇足ついでにテキスト変更してみた・・おまけです

#ms365 #PowerPointVBA #マクロ #PowerPoint #パワポ #パワーポイント
#ExcelVBA #エクセル
#テキスト #図形 #位置を移動
#作成方法 #初心者 #プレゼン
#Left #Top

1.テキストや図形の位置LeftとTopを取得 01:25 ～

図001 PowerPointからテキスト・図形の位置をExcelシートへ

過去に作成した、似ている処理を修正してみます。

Excel VBA で PowerPointのタイトルテキストを取得したい Shapes から テキストを取り出す
ken3memo.hatenablog.com
↑ここのソースコードに、
位置.Leftと.Topを取得してC列・D列にセットする
下記コードを追加で書いただけでした。

'起動済みの既存 パワーポイント
'スライド .Shapes から 位置 Left,Top と テキストを取り出す
'アクティブシートに名前と位置,テキストをセット ※勝手に全クリアして書き込むので※※注意
Sub test20230225_01スライド内テキストの位置と中身を取得()

    Dim ppApp As Object 'As PowerPoint.Application
    
    Set ppApp = Nothing 'エラーチェックのため初期化
    On Error Resume Next  '取得エラー時に次へ行く
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意

    If ppApp Is Nothing Then
        MsgBox "パワポを取得できません。プレゼンスライドを開いてから、再テストしてね"
        Exit Sub
    End If

    Cells.ClearContents     'アクティブシートを※勝手に全クリアして書き込むので※※注意
    Range("A1").Select
    '見出しを書き込む
    Range("A1") = "Page番号"
    Range("B1") = "名前 Shape.Name"
    Range("C1") = "左位置.Left"
    Range("D1") = "上位置.Top"
    Range("E1") = "テキスト objShape.TextFrame.TextRange.Text"

    Dim p As Integer, y As Integer   'pページ、y行
    Dim objShape As Object  'As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
        
    y = 2  '取得したテキストデータを二行目から書きたいので
    For p = 1 To ppApp.ActivePresentation.Slides.Count  'スライド数ループ pページ
        'pページのスライド内のシェイプを探る
        For Each objShape In ppApp.ActivePresentation.Slides(p).Shapes
            Cells(y, "A") = p   'スライド番号(ページ番号)
            Cells(y, "B") = objShape.Name  'オブジェクトの名前
         
            Cells(y, "C") = objShape.Left  '位置 左上の左 20230225追加
            Cells(y, "D") = objShape.Top   '位置 左上の縦
         
            'オブジェクトがテキストを持っているか？チェックしてからセット
            If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり
                If objShape.TextFrame.HasText = msoTrue Then 'テキスト範囲あり
                    Cells(y, "E") = objShape.TextFrame.TextRange.Text 'E列へテキスト
                End If
            End If
            
            y = y + 1   'セットする行を次へ
            
        Next
    Next
    
    MsgBox "処理終了、確認してください"
    
End Sub

2.シートの値をShape.Leftと.Topにセット 04:01 ～
上でシートに値を取り込めたので、
今度は逆の シートの値(Left,Top)を 既存のパワポにセットしてみます

図002 Excelシートで修正・調整した位置をPowerPointのテキスト・図形にセットして移動する

まぁ、特に凝った処理はしていなくて

p = Cells(y, "A")          'A列からスライド番号(ページ番号)
strShpName = Cells(y, "B") 'B列から名前
'A列から↑pページ B列の名前を使う
Set objShape = ppApp.ActivePresentation.Slides(p).Shapes(strShpName)

で、単純に取得
あとは、値のセットで、これも単純にC列とD列の値をセットしただけでした

'やっと位置をセット、これで移動っぽくしてみた
objShape.Left = Cells(y, "C")   '位置 左上の左 20230225追加
objShape.Top = Cells(y, "D")    '位置 左上の縦

完成したソースコードが下記です。アレンジして使ってみてください。

'起動済みの既存 パワーポイント
'シートの値(Left,Top)を 既存のパワポにセットしてみます
'アクティブシートのA列のPage B列のシェイプに
'C列LeftとD列Topをセット
Sub test20230225_02シェイプの位置LeftとTopをセットする()

    Dim ppApp As Object 'As PowerPoint.Application
    
    Set ppApp = Nothing 'エラーチェックのため初期化
    On Error Resume Next  '取得エラー時に次へ行く
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意

    If ppApp Is Nothing Then
        MsgBox "パワポを取得できません。プレゼンスライドを開いてから、再テストしてね"
        Exit Sub
    End If

    Dim p As Integer, y As Integer   'pページ、y行
    Dim strShpName As String  'シェイプの名前
    Dim objShape   As Object  'As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
        
    y = 2  '1行目が見出しなので、二行目からデータをセットする
    While Len(Cells(y, "A")) <> 0 'A列の文字数が0以外の間ループ、A列がなくなるまで
        p = Cells(y, "A")          'A列からスライド番号(ページ番号)
        strShpName = Cells(y, "B") 'B列から名前
        Set objShape = Nothing  '初期化
        On Error Resume Next  '取得エラー時に次へ行く
        'pページのスライド内のシェイプを取得 A列のページ と B列の名前を使う
        Set objShape = ppApp.ActivePresentation.Slides(p).Shapes(strShpName)
        On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
        
        If objShape Is Nothing Then  '名前のエラーチェック
            MsgBox p & "ページの名称" & strShpName & "が見つかりません、確認してください"
            Exit Sub
        End If
        
        'やっと位置をセット、これで移動っぽくしてみた
        objShape.Left = Cells(y, "C")   '位置 左上の左 20230225追加
        objShape.Top = Cells(y, "D")    '位置 左上の縦

        y = y + 1   '次のデータへ
            
    Wend
    
    MsgBox "処理終了、確認してください"
    
End Sub

3.コードの組み込み方法 09:43 ～

detail.chiebukuro.yahoo.co.jp

上記、知恵袋の質問 タイトル位置を移動させたいを実演してみる

おまけ、って言うか、本題？
知恵袋の質問 タイトル位置を移動させたいを実演してみる

目的のパワポを開きます(※コピーしてから使ってくださいね)
新規、Excelブックを開きます

3.1 取得コードを組み込む テストする 10:12 ～

'下記のコードをコピーします
    Dim ppApp As Object 'As PowerPoint.Application
    
    Set ppApp = Nothing 'エラーチェックのため初期化
    On Error Resume Next  '取得エラー時に次へ行く
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意

    If ppApp Is Nothing Then
        MsgBox "パワポを取得できません。プレゼンスライドを開いてから、再テストしてね"
        Exit Sub
    End If

    Cells.ClearContents     'アクティブシートを※勝手に全クリアして書き込むので※※注意
    Range("A1").Select
    '見出しを書き込む
    Range("A1") = "Page番号"
    Range("B1") = "名前 Shape.Name"
    Range("C1") = "左位置.Left"
    Range("D1") = "上位置.Top"
    Range("E1") = "テキスト objShape.TextFrame.TextRange.Text"

    Dim p As Integer, y As Integer   'pページ、y行
    Dim objShape As Object  'As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
        
    y = 2  '取得したテキストデータを二行目から書きたいので
    For p = 1 To ppApp.ActivePresentation.Slides.Count  'スライド数ループ pページ
        'pページのスライド内のシェイプを探る
        For Each objShape In ppApp.ActivePresentation.Slides(p).Shapes
            Cells(y, "A") = p   'スライド番号(ページ番号)
            Cells(y, "B") = objShape.Name  'オブジェクトの名前
         
            Cells(y, "C") = objShape.Left  '位置 左上の左 20230225追加
            Cells(y, "D") = objShape.Top   '位置 左上の縦
         
            'オブジェクトがテキストを持っているか？チェックしてからセット
            If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり
                If objShape.TextFrame.HasText = msoTrue Then 'テキスト範囲あり
                    Cells(y, "E") = objShape.TextFrame.TextRange.Text 'E列へテキスト
                End If
            End If
            
            y = y + 1   'セットする行を次へ
            
        Next
    Next
    
    MsgBox "処理終了、確認してください"
'↑ここまで

3.1.1 sheet1に図形を挿入します。
3.1.2 右クリックを押しマクロの登録を選択します
3.1.3 新規作成をします

コードを貼り付けます

3.1.4 Excelの図形を押して確認します

---

3.2 移動のコードを組み込む テストする 12:08 ～

シートを追加します
※隣に新規シートを追加します。

テストなので、1～2ページのタイトルをコピーします

'下記のコードをコピーします
    Dim ppApp As Object 'As PowerPoint.Application
    
    Set ppApp = Nothing 'エラーチェックのため初期化
    On Error Resume Next  '取得エラー時に次へ行く
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意

    If ppApp Is Nothing Then
        MsgBox "パワポを取得できません。プレゼンスライドを開いてから、再テストしてね"
        Exit Sub
    End If

    Dim p As Integer, y As Integer   'pページ、y行
    Dim strShpName As String  'シェイプの名前
    Dim objShape   As Object  'As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
        
    y = 2  '1行目が見出しなので、二行目からデータをセットする
    While Len(Cells(y, "A")) <> 0 'A列の文字数が0以外の間ループ、A列がなくなるまで
        p = Cells(y, "A")          'A列からスライド番号(ページ番号)
        strShpName = Cells(y, "B") 'B列から名前
        Set objShape = Nothing  '初期化
        On Error Resume Next  '取得エラー時に次へ行く
        'pページのスライド内のシェイプを取得 A列のページ と B列の名前を使う
        Set objShape = ppApp.ActivePresentation.Slides(p).Shapes(strShpName)
        On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
        
        If objShape Is Nothing Then  '名前のエラーチェック
            MsgBox p & "ページの名称" & strShpName & "が見つかりません、確認してください"
            Exit Sub
        End If
        
        'やっと位置をセット、これで移動っぽくしてみた
        objShape.Left = Cells(y, "C")   '位置 左上の左 20230225追加
        objShape.Top = Cells(y, "D")    '位置 左上の縦

        y = y + 1   '次のデータへ
            
    Wend
    
    MsgBox "処理終了、確認してください"
'ここまで

3.2.1 sheet2(追加した隣のシート)に図形を挿入します。
3.2.2 右クリックを押しマクロの登録を選択します
3.2.3 新規作成をします

コードを貼り付けます

3.2.4 Excelの図形を押して確認します

---

3.3 基準となるタイトル位置を決めます

3.4 Sheet1でデータを取得します

3.5 フィルターをかけ Title1を絞り込みます

3.6 タイトルのデータをコピーします

3.7 隣の移動用シートに貼り付けます

3.8 基準となる データをコピーします

3.9 マクロを走らせます

---

3.10 なんて、感じでうまくいけばいいんだけど、 20:06 ～
そんなに世の中、実データは甘くなかったり・・・

＞3.5 フィルターをかけ Title1を絞り込みます

なんて、書いてたけど、
タイトルって？そのまま使う人と、
ア.白紙から作る人がいたり
イ.間違ってタイトルを消してしまい、テキストボックスで同じ位置に追加したり・・・

Title1って、名前じゃなかったりして・・・

そんな時は、フィルターの絞り込みで、LeftとTopを範囲指定して、なんとかするのかなぁ・・・

以上、アレンジして、使ってみてください。

大量スライドの図形やテキストの移動時
作業軽減となればうれしいです。

終わりにすればいいのに、蛇足で思い付きのテキスト変更をやってみた・・・
4.蛇足ついでにテキスト変更してみた・・おまけです 24:05 ～

objShape.TextFrame.TextRange.Text = Cells(y, "E") 

↑動画内では、E列を逆に TextFrame.TextRange へ戻して
それっぽくうまくいったけど、
テキストを持たないオブジェクトにセットすると、
エラーになると思うので、少し細工が必要かも。
まぁ、おまけの処理、思い付きなので、
チェックなどを入れて、アレンジしてください。

※下記、冒頭と同じ動画です。本文が長くなったので、下にも貼りました
マクロ パワポ テキストや図形の位置LeftとTopを取得 大量のテキスト・図形を移動 PowerPoint VBA作成方法を初心者がプレゼンしてみた - YouTube
目次
00:00 やりたいこと
01:25 1.テキストや図形の位置LeftとTopを取得
04:01 2.シートの値をShape.Leftと.Topにセット
09:43 3.コードの組み込み方法
10:12 3.1 取得コードを組み込む テストする
12:08 3.2 移動のコードを組み込む テストする
14:00 3.3 基準となるタイトル位置を決めます
14:44 3.4 Sheet1でデータを取得します
15:01 3.5 フィルターをかけ Title1を絞り込みます
15:34 3.6 タイトルのデータをコピーします
15:44 3.7 隣の移動用シートに貼り付けます
15:52 3.8 基準となる データをコピーします 3.9 マクロを走らせます
18:18 タイトル以外の違う項目を移動テストする
20:06 3.10 タイトルに規則性が無かったら？どうする？
24:05 4.蛇足ついでにテキスト変更してみた・・おまけです