[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『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
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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.