『EXCEL VBAでパワポ内を検索したい』（もひ）

質問失礼いたします。

Excelでグラフを作成し、
Powerpointの特定の文字列があるスライドに
貼りつける仕組みを作りたいと思っています。

しかしExcel VBAとパワポの連携は事例も少なく、
連日色々と試してみたもののまったく実現できませんでした。
お力を貸していただきたく、どうぞよろしくお願いいたします。


Sub スライドを選択して図を貼りつけ()

  Dim ppApp As Object 
  Dim ppPst As Object
 
  Set ppApp = CreateObject("PowerPoint.Application")
  Set ppPst = ppApp.ActivePresentation

'--------データを図としてコピー
  ChartObjects("グラフ 1").CopyPicture Appearance:=xlScreen, Format:=xlPicture 

'--------パワポ内でA1セルの語句を検索
'--------　スライド番号を取得　したい
  ppPst.Find (Range("A1").Value).Select
  i = ppPst.SlideRange.SlideIndex

  ppPst.Paste

End Sub




＜ 使用 Excel：Excel2013、使用 OS：Windows7 ＞
----
 これってExcelというよりもPowerPointのVBAの質問のように思いますが、
 勉強がてらやってみたら、以下でできました。グラフも検索文字も固定で適当です。

 Sub Macro1()

    Dim ppApp As Object
    Dim ppPst As Object
    
    Set ppApp = CreateObject("PowerPoint.Application")
    Set ppPst = ppApp.ActivePresentation

    ThisWorkbook.Sheets(1).ChartObjects("グラフ 1").CopyPicture Appearance:=xlScreen, 
 Format:=xlPicture
  
    For Each sld In ppPst.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                Set txtRng = shp.TextFrame.TextRange
                Set foundText = txtRng.Find(FindWhat:="あああ")
                Do While Not (foundText Is Nothing)
                    With foundText
                        sld.Shapes.Paste
                        Exit Do
                    End With
                Loop
            End If
        Next
    Next
      
    Set ppPst = Nothing
    Set ppApp = Nothing

 End Sub

 ちなみに、ExcelのグラフをPowerPointに貼りつける部分は以下のサイトを参考にしました。

 簡単！エクセルVBAでシート上のグラフをコピーしてPowerPointにペーストする
 https://tonari-it.com/excel-vba-powerpoint-chat-copy-paste/

 ※Googleでキーワード「vba excelのグラフをpowerpointに貼り付け」で1番上に出てきました。

 PowerPointで語句を検索する部分は以下を参考にしました。

 TextRange メソッド (PowerPoint) | Microsoft Docs
 https://docs.microsoft.com/ja-jp/office/vba/api/powerpoint.textrange.find

 ※Googleでキーワード「powerpoint vba 文字 検索」で出てきました。

 私も勉強がてらやってみただけなのでこれ以上は分かりません。
 上記のキーワードで検索するといろいろと情報が出てくるのは？

（う） 2019/07/18(木) 10:09
----
 あっ、
 さっきのサンプルだと1つのスライドに複数のShapesがあり、
 検索文字がそれぞれのShapesにあると同じグラフが何度も張り付いてしまうので、
 フラグ変数とか使って、1つのスライドで1回しか張り付かないように制御を追加する必要がありますね。

 ご注意を。
（う） 2019/07/18(木) 10:19
----
 ん？もう一つ気づいた。何度もすみません。
 そもそもDo While Not (foundText Is Nothing)でループする必要はなく、
 IFで判定だけで良かったですね。

 「見つかった文字を太字にする」サンプルを利用したので、余計な動きになっていました。
 そうすると、前にコメントしたフラグもいらないので、こんな感じかな。

 Sub Macro1()
    Dim ppApp As Object
    Dim ppPst As Object
    
    Set ppApp = CreateObject("PowerPoint.Application")
    Set ppPst = ppApp.ActivePresentation
    ThisWorkbook.Sheets(1).ChartObjects("グラフ 1").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    For Each sld In ppPst.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                Set txtRng = shp.TextFrame.TextRange
                Set foundText = txtRng.Find(FindWhat:="あああ")
                If Not (foundText Is Nothing) Then
                    sld.Shapes.Paste
                    Exit For
                End If
            End If
        Next
    Next
    Set ppPst = Nothing
    Set ppApp = Nothing
 End Sub

 一応、１スライドに１つしかペーストされないことは確認済み。
 すでに張り付いているかどうかのチェックはしていません。

 また、参考にしたサンプルが「完全に一致する単語をすべて検索」だったので、上記も完全一致です。
（う） 2019/07/18(木) 10:40
----
う 様

ご回答いただきましてありがとうございます！！
自力では絶対に辿り着けないコードでした……
こんなにも丁寧に、参考サイトや注意事項までいただいて本当に感謝です！

重ねての質問で大変恐縮なのですが、
下記２つにつきましてもご教示いただけないでしょうか？
何とぞよろしくお願いいたします。

'-----------------------------------------------------------

(1)貼り付けた画像の位置を調整したく
　　sld.Shapes.Pasteの次行で下記のコードを挿入したところ
　　“オブジェクト変数または With ブロック変数が……”と
　　エラーが出てしまいました。
　　Withの直後のオブジェクトの指定が原因と思われるのですが、、
　　解決方法を教えていただけますと大変助かります。

    With ppPst.ActiveWindow.Selection    'エラーの原因？
      .LockAspectRatio = msoTrue '縦横比固定
      .Top = 100            '上からの位置
      .Left = 50            '左からの位置
      .Width = 800          '横幅
      .Height = 600         '縦幅
      .ZOrder msoSendToBack '最背面へ移動
    End With

'-----------------------------------------------------------

(2)新規スライドに貼り付けたい追加グラフがあり、
　　「A1セルの語句を含むスライドの手前に新規スライドを挿入し貼付け」
　　という動作を追加したく、下記のような記述を追加したいのですが
　　この i にどのような記述をするべきか教えていただけないでしょうか？

    'PowerPointスライド追加
    i = 'ここに特定の語句を含むスライド番号
    Set ppSld = ppPst.Slides.Add(Index:=i + 0, Layout:=12)

'-----------------------------------------------------------

恐縮と言いつつ長々と申し訳ありません。

いただいた参考サイトや検索などで自分でも引き続き
調べて参りますが、お知恵をお借りできましたら大変幸いです。

何とぞよろしくお願いいたします。


（もひ） 2019/07/18(木) 19:19
----
 そういう質問になりますよね、、、
 なので「私も勉強がてらやってみただけなのでこれ以上は分かりません。」とけん制しておいたのですが、、、

 >(1)貼り付けた画像の位置を調整したく 

 sld.Shapes.Paste   
 With ppPst.ActiveWindow.Selection    'エラーの原因？

   ↓

 With sld.Shapes.Paste   

 としたら、だめですかね。


 >(2)スライドの番号

 i = sld.SlideIndex

 では？
 
 「For Each sld In ppPst.Slides」で、変数「sld」がスライドであることは分かると思います。
 あとは、この変数のスライドの番号が取得できればいいわけで、
 以下のサイトを見ると、スライド番号のプロパティ名が「SlideIndex」であることが分かります。

 現在編集中のスライド番号を取得するPowerPoint VBAのコード
 https://www.relief.jp/docs/017912.html

 ※googleでキーワード「VBA スライド番号」で最初に出てくる。

 ちなみに私は、sld.Shapes.Pasteにブレークポイントを設定してマクロを中断し、
 ローカルウィンドウで、変数「sld」の情報を確認。
 基本的に英語なので「Indexとついてるものはあるかな？」と探しました。
 その上で、ネットで検索して確認。

 今回はネットで調べればすぐに出てきましたが、プロパティ名が分からない時にこの方法はまたに使います。
 プロパティの値が確認できるので「この値が入っているもの」（例：スライド3であれば、3と入っているもの）ってので探せるので。


（う） 2019/07/19(金) 10:45
----
（１）貼った画像のサイズを変えるなら、以下のように貼ったオブジェクトのプロパティとして設定してしまえば良いでしょう。
                    With sld.Shapes.Paste
                        .LockAspectRatio = msoTrue '縦横比固定
                        .Top = 100            '上からの位置
                        .Left = 50            '左からの位置
                        .Width = 800          '横幅
                        .Height = 600         '縦幅
                        .ZOrder msoSendToBack '最背面へ移動
                    End With

（２）末尾にスライド追加するだけなら、以下とか。
    ppPst.Slides.Add Index:=ppPst.Slides.Count + 1, Layout:=12
（???） 2019/07/19(金) 10:52
----
あぁ、末尾って訳じゃないんですね。 ならsldのインデックスを元に、ですね。
（???） 2019/07/19(金) 10:56
----
または、元々あったコードに出てきた i という変数を重要視するなら、後ろから検索していけば多重挿入問題は発生しないので、以下とか。
 Sub test()
    Dim ppApp As Object
    Dim ppPst As Object
    Dim shp As Object
    Dim txtRng As Variant
    Dim foundText As Variant
    Dim i As Long

    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Presentations.Open "プレゼンテーション1.pptx"
    Set ppPst = ppApp.ActivePresentation
    ThisWorkbook.Sheets(1).ChartObjects("グラフ 1").CopyPicture Appearance:=xlScreen, Format:=xlPicture

    For i = ppPst.Slides.Count To 1 Step -1
        For Each shp In ppPst.Slides(i).Shapes
            If shp.HasTextFrame Then
                Set txtRng = shp.TextFrame.TextRange
                Set foundText = txtRng.Find(FindWhat:="あああ")
                If Not (foundText Is Nothing) Then
                    With ppPst.Slides.Add(Index:=i, Layout:=12)
                        With .Shapes.Paste
                            .LockAspectRatio = msoTrue '縦横比固定
                            .Top = 100            '上からの位置
                            .Left = 50            '左からの位置
                            .Width = 800          '横幅
                            .Height = 600         '縦幅
                            .ZOrder msoSendToBack '最背面へ移動
                        End With
                    End With
                    Exit For
                End If
            End If
        Next shp
    Next i

    Set ppPst = Nothing
    Set ppApp = Nothing
 End Sub
（???） 2019/07/19(金) 11:10
----
う 様 

ご回答いただきましてありがとうございます！
牽制いただいていると知りながらの厚かましいお願いにも
親切にご対応くださり、心から感謝いたします。

何時間にも渡りネットを調べたのですが
そこで得た情報を集約するだけの基礎知識がなく、
リミットのある作業で１から勉強する猶予もなく、
どうしたものかと途方に暮れておりましたので
本当に助かりました。

ご返信、何度も読ませていただいています。
誠にありがとうございます。

'----------------------------------------------------------

（???）様

ご回答いただきましてありがとうございます！
本当に困っておりましたので、深く深く感謝いたします。
今作成しているデータをもっと良いものにできました！

こちらでご相談させていただいて本当によかったです。
VBA、音を上げるほど難しいですがとても楽しいとも
感じられるのは、ひとえに貴重な知識を分けてくださる
皆さまのおかげです。

また長々と申し訳ございません。皆さまの益々のご活躍と、
よきExcelライフをお祈り申し上げます。
誠にありがとうございます。


（もひ） 2019/07/19(金) 22:50