パワポ 1ページ目のテキストや図形を最終ページまで同じ位置にコピペする方法

全スライドにアニメーション付きの図形を同じ位置にコピーしたい
www.youtube.com
https://www.youtube.com/watch?v=gWGkkzfn2qo
目次
00:00 1.キッカケの質問を紹介
00:35 2.AI Bingに聞いてみた
02:42 3.コードを貼り付けて実行 chatGPTはたまにうそをつく？
03:28 3.1 コードの編集画面に行きコードを貼り付けます
04:18 表示マクロから作成する方法

05:24 3.2 コードを貼り付けて、実行します。
06:45 コンパイルエラー発生教えてもらったコードを貼っただけなのに・・・
07:34 シェイプの名前でエラー発生
08:07 シェイプの名前を調べる方法ホーム配置オブジェクトの選択と表示
09:48 コードを簡単に説明する
11:03 やっと、実行確認
12:19 再テストで不具合を解説

15:22 4.おわりの挨拶と問題点二回走らせると・・・
18:43 4.1 取り扱い注意の文字をテキストで左下に
20:33 4.2 取扱注意を社外秘にして、赤で囲ってと修正受けたとき
21:53 再度、頭から、まとめる。

1.キッカケの質問を紹介
detail.chiebukuro.yahoo.co.jp

＞PowerPointにて、全スライドにアニメーション付きの図形を同じ位置にコピーしたいです。
＞1枚１枚するのは非常に手間なので(80枚あるので)、何かいい方法はありませんか。
＞スライドマスター以外でお願いしたいです。よろしくお願いいたします。

2.AI Bingに聞いてみた

Use PowerPointVBA
1スライド目のシェイプ名"textbox1"をアニメーション付きでコピーして、
2スライドから最終スライドまで、同じ位置にアニメ付きで貼り付ける。
コードを教えてください。よろしくお願いします。

とBing(chatGPT)に質問すると、

Sub CopyTextboxWithAnimation()  'エラーが発生します
    Dim sld As Slide
    Dim shp As Shape
    Dim i As Integer
    
    Set sld = ActivePresentation.Slides(1)
    Set shp = sld.Shapes("textbox1")
    
    For i = 2 To ActivePresentation.Slides.Count
        shp.Copy
        ' ppPasteTextEffect で エラー発生
        ' chatGPTはたまにプロパティや定数を言葉として創造して、エラーになりますね・・・言語だから？ 
        ActivePresentation.Slides(i).Shapes.PasteSpecial ppPasteTextEffect, msoFalse, msoFalse, shp.Left, shp.Top
    Next i
End Sub

↑を参考に作ると、便利です。
これを直してみます。
※と初見ぽく言ってますが、
テストしてからライブを始めたので、初見じゃなくて2回目です。

今回は、
ActivePresentation.Slides(i).Shapes.PasteSpecial ppPasteTextEffect, msoFalse, msoFalse, shp.Left, shp.Top
を
ActivePresentation.Slides(i).Shapes.PasteSpecial
のパラメーター無しの貼り付けで使用しました。

Sub CopyTextboxWithAnimation()  'こっちを使って下さい。
    Dim sld As Slide
    Dim shp As Shape
    Dim i As Integer
    
    Set sld = ActivePresentation.Slides(1)
    Set shp = sld.Shapes("textbox1")
    
    For i = 2 To ActivePresentation.Slides.Count
        shp.Copy
        ' ppPasteTextEffect で エラー発生するので、削除しました。
        ' chatGPTはたまにプロパティや定数を言葉として創造して、エラーになりますね・・・言語だから？ 
        ActivePresentation.Slides(i).Shapes.PasteSpecial
    Next i
End Sub

余談:同じ質問を投げても、違う回答が返ってくるのも、chatGPTらしい？
下記、テストで実行したら、違うコードが返ってきて、少しびっくりした・・・
https://www.youtube.com/watch?v=gWGkkzfn2qo&t=00m35s
↑でテストすると下記が返ってきたり。

Sub CopyTextbox1()
    Dim sld As Slide
    Dim shp As Shape
    Dim i As Integer
    
    Set sld = ActivePresentation.Slides(1)
    Set shp = sld.Shapes("textbox1")
    
    For i = 2 To ActivePresentation.Slides.Count
        shp.Copy
        ActivePresentation.Slides(i).Shapes.PasteSpecial ppPasteTextEffect
        With ActivePresentation.Slides(i).Shapes(ActivePresentation.Slides(i).Shapes.Count)
            .Left = shp.Left
            .Top = shp.Top
        End With
    Next i
End Sub