[[20180228101029]]　『（PowerPoint）のスライドにEXCELファイルを添付ａx（みゆき）　ページの最後に飛ぶ

『（PowerPoint）のスライドにEXCELファイルを添付する』（みゆき）

おはようございます。
PowerPointのスライドにEXCELファイルを添付するマクロをご教授願います。
PowerPointのスライドの10番目にEXCELファイルを添付したいのです。
いろいろ調べてみましたが、わかりませんでした。
よろしくお願いします。

＜使用 Excel：Excel2013、使用 OS：Windows7 ＞

 あまり意味を理解できていないかもしれませんが、
 パワポの10番目のスライドにエクセルの指定セル範囲を貼付するようにしています。

 Sub TEST()

     Dim PP_App As Object
     Dim PP_Pst As Object
     Dim PP_Sld As Object

    'PowerPointを起動
    Set PP_App = CreateObject("PowerPoint.Application")
    PP_App.Visible = msoTrue

    'PowerPointを開く
    Set PP_Pst = PP_App.Presentations.Open("C:\TEST\プレゼンテーション1.pptx")

    'Excelのシート1の範囲をコピー（ここではシート1のA1:C10としています）
    ThisWorkbook.Worksheets(1).Range("A1:C10").CopyPicture xlScreen, xlPicture

    'スライド10番目をセット
    Set PP_Sld = PP_Pst.Slides(10)

    '貼り付け
    PP_Sld.Shapes.Paste

    '位置の調整
    With PP_Sld.Shapes(1)
      .LockAspectRatio = msoFalse
      .Top = 80
      .Left = 80
    End With

    'オブジェクト解放
    Set PP_App = Nothing
    Set PP_Pst = Nothing
    Set PP_Sld = Nothing

 End Sub
（ろっくん） 2018/02/28(水) 12:49

ろっくんさん回答有難うございます。

＞'位置の調整→PowerPointの１０番目のスライドにタイトルが入力してあります。
　エクセルの表は、貼付できましたがタイトルが動いて位置調整されます。

＞PowerPointのスライドの10番目にEXCELファイルを添付したいのです。
申し訳ありません。私は、「EXCELファイルを添付」したいのです。

よろしくお願いします。
（みゆき） 2018/03/01(木) 09:59

 失礼しました。違っていましたか。
 では、下記のどちらかが該当しますでしょうか。
 TEST3の引数IconFileNameの場所についてはご自身のExcelの格納場所に変更してください。

 Sub TEST2()
     Dim PP_App As Object
     Dim PP_Pst As Object
     Dim PP_Sld As Object
     Const InsertFileName As String = "C:\TEST\TEST.xlsm"
    'PowerPointを起動
    Set PP_App = CreateObject("PowerPoint.Application")
    PP_App.Visible = msoTrue
    'PowerPointを開く
    Set PP_Pst = PP_App.Presentations.Open("C:\TEST\プレゼンテーション1.pptx")
    'スライド10番目をセット
    Set PP_Sld = PP_Pst.Slides(10)
    '挿入
    PP_Sld.Shapes.AddOLEObject Left:=100, Top:=100, Width:=250, Height:=100, Filename:=InsertFileName, Link:=msoTrue
    'オブジェクト解放
    Set PP_App = Nothing
    Set PP_Pst = Nothing
    Set PP_Sld = Nothing
 End Sub

 Sub TEST3()
     Dim PP_App As Object
     Dim PP_Pst As Object
     Dim PP_Sld As Object
     Const InsertFileName As String = "C:\TEST\TEST.xlsm"
    'PowerPointを起動
    Set PP_App = CreateObject("PowerPoint.Application")
    PP_App.Visible = msoTrue
    'PowerPointを開く
    Set PP_Pst = PP_App.Presentations.Open("C:\TEST\プレゼンテーション1.pptx")
    'スライド10番目をセット
    Set PP_Sld = PP_Pst.Slides(10)
    '挿入
    PP_Sld.Shapes.AddOLEObject Left:=100, Top:=100, Width:=250, Height:=100, Filename:=InsertFileName, _
        DisplayAsIcon:=True, IconFileName:="C:\Program Files (x86)\Microsoft Office\Office15\EXCEL.EXE", _
        Link:=msoTrue, IconLabel:=InsertFileName
    'オブジェクト解放
    Set PP_App = Nothing
    Set PP_Pst = Nothing
    Set PP_Sld = Nothing
 End Sub
（ろっくん） 2018/03/01(木) 13:12

Sub TEST3() でエクセルファイルを貼り付けることができました。
私、見当もつかなかったにすごい。天才です。
大変　勉強になりました。有難うございました。
（みゆき） 2018/03/01(木) 16:06

ろっくん様　「Sub TEST3()」についてもう少しご教授下さい。
パワーポイントを開くときに
「このプレゼンテーションは、他のファイルへのリンクが含まれています・・・」
「リンクを更新」ボタン、「キャンセル」ボタンが表示されます。
この「リンクを更新」画面をださないようにエクセルファイルをパワーポイントへ貼り付ける方法はありませんか。ご教授よろしくお願いします。
（みゆき） 2018/03/26(月) 08:36

 リンクの更新を手動に変更するコードを組み込みました。
 Sub TEST4()
     Dim PP_App As Object
     Dim PP_Pst As Object
     Dim PP_Sld As Object
     Dim Shp As Object
     Const InsertFileName As String = "C:\TEST\TEST.xlsm"
    'PowerPointを起動
    Set PP_App = CreateObject("PowerPoint.Application")
    PP_App.Visible = msoTrue
    'PowerPointを開く
    Set PP_Pst = PP_App.Presentations.Open("C:\TEST\プレゼンテーション1.pptx")
    'スライド10番目をセット
    Set PP_Sld = PP_Pst.Slides(10)
    '挿入
    Set Shp = PP_Sld.Shapes.AddOLEObject(Left:=100, Top:=100, Width:=250, Height:=100, Filename:=InsertFileName, _
        DisplayAsIcon:=True, IconFileName:="C:\Program Files (x86)\Microsoft Office\Office15\EXCEL.EXE", _
        Link:=msoTrue, IconLabel:=InsertFileName)
    'リンク更新を手動に変更
    Shp.LinkFormat.AutoUpdate = 1
    'オブジェクト解放
    Set PP_App = Nothing
    Set PP_Pst = Nothing
    Set PP_Sld = Nothing
 End Sub
（ろっくん） 2018/03/26(月) 09:55

 追記です。
 このマクロで貼り付けるリンク以外にシェープにリンクが埋め込まれている場合は
 すべてのリンクオブジェクトに対してリンク更新を手動に切り替える必要があります。

 Sub TEST5()
     Dim PP_App As Object
     Dim PP_Pst As Object
     Dim PP_Sld As Object
     Dim Shp As Object
     Dim Sld As Object
     Const InsertFileName As String = "C:\TEST\TEST.xlsm"
    'PowerPointを起動
    Set PP_App = CreateObject("PowerPoint.Application")
    PP_App.Visible = msoTrue
    'PowerPointを開く
    Set PP_Pst = PP_App.Presentations.Open("C:\TEST\プレゼンテーション1.pptx")
    'スライド10番目をセット
    Set PP_Sld = PP_Pst.Slides(10)
    '挿入
    Set Shp = PP_Sld.Shapes.AddOLEObject(Left:=100, Top:=100, Width:=250, Height:=100, Filename:=InsertFileName, _
        DisplayAsIcon:=True, IconFileName:="C:\Program Files (x86)\Microsoft Office\Office15\EXCEL.EXE", _
        Link:=msoTrue, IconLabel:=InsertFileName)
    'リンク更新を手動に変更（すべてのスライドのすべてのシェープ）
    For Each Sld In PP_Pst.Slides
        For Each Shp In Sld.Shapes
            If Shp.Type = 10 Then   'msoLinkedOLEObject
                Shp.LinkFormat.AutoUpdate = 1   'ppUpdateOptionManual
            End If
        Next
    Next
    'オブジェクト解放
    Set PP_App = Nothing
    Set PP_Pst = Nothing
    Set PP_Sld = Nothing
 End Sub
（ろっくん） 2018/03/26(月) 11:57

ろっくん様　ご教授有難うございました。
エクセルファイルをリンクなしで貼り付けることができました。
有難うございます。今後ともよろしくお願いします。
（みゆき） 2018/03/26(月) 16:19

こんにちわ。
ご教授よろしくお願いします。

１、エクセルファイル間のデータをコピーする処理
２、エクセルグラフをパワーポイントに貼り付ける処理
３．上記の「TEST5」のろっくんさんのマクロ処理

を続けて実行してみました。

Sub １２３を実行

    call エクセルファイル間のデータをコピーする処理
    call エクセルグラフをパワーポイントに貼り付ける処理
    call TEST5 
End Sub

下記の　（TEST5）のマクロ中でセルが黄色くなって停止、実行時エラーがでました。

    '挿入
    Set Shp = PP_Sld.Shapes.AddOLEObject(Left:=100, Top:=100, Width:=250, Height:=100, Filename:=InsertFileName, _
        DisplayAsIcon:=True, IconFileName:="C:\Program Files\Microsoft Office\Office14\EXCEL.EXE", _
        Link:=msoTrue, IconLabel:=InsertFileName)

エラー内容：
実行時エラー'-2147467259(800004005)
オートメーションエラーです。
エラーを特定できません。

エラー内容をネットで調べて対処してみましたがうまくいきません。
どうしたらよいでしょう。
ご教授よろしくお願いします。

（みゆき） 2018/03/29(木) 11:52

 コードを提示できますか？
（ろっくん） 2018/03/29(木) 17:22

ろっくん様　
（TEST5）のマクロのみを実行すればエラーはでませんでした。
しかし、１，２，３のマクロを続けて実行するときに「実行時エラー'-2147467259(800004005) 」がでます。

コードは、ちょっと長いです。
１、エクセルファイル間のデータをコピーする処理（コピー処理のみ）

２、エクセルグラフをパワーポイントに貼り付ける処理

３．上記の「TEST5」のろっくんさんのマクロ処理

　（3番目のコードは、ろっくんさんの教えてくれた「Sub TEST5()」のマクロ）

2番目は、下記に表示します。

ご確認よろしくお願いします。

Sub PowerPointを起動してプレゼンテーションを開く()

 Dim PPT保存フォルダ  As String, PPT呼出ファイル名  As String, PPT書込ファイル名  As String

マクロブック名取得 = ActiveWorkbook.Name 'ブック名の取得
Windows(マクロブック名取得).Activate

 PPT保存フォルダ = Worksheets("マスタ").Cells(51, 18)
 PPT呼出ファイル名 = Worksheets("マスタ").Cells(51, 19)
 PPT呼出 = PPT保存フォルダ & "\" & PPT呼出ファイル名

    Set Pポイント = CreateObject("PowerPoint.Application")         'PowerPointを起動
    Pポイント.Visible = True                               'PowerPointを表示
    Set プレゼン = Pポイント.Presentations.Open(PPT呼出)           'プレゼンテーションを開く

End Sub

'図形で貼付られたグラフをPPTへ貼付
Sub GRF()

 Dim PPT保存フォルダ As String, PPT書込ファイル名  As String

マクロブック名取得 = ActiveWorkbook.Name 'ブック名の取得
Windows(マクロブック名取得).Activate

 PPT書込ファイル名 = Worksheets("マスタ").Range("T51")
 PPT保存フォルダ = Worksheets("マスタ").Range("R51")

  'コレクション生成
  Set Objs = New Collection

  '「グラフ貼付2」シートにグラフ（図形）あり
  Dim s1 As Worksheet: Set s1 = Sheets("グラフ貼付2")       
  Dim s2 As Worksheet: Set s2 = Sheets("グラフ貼付2")        
  Dim s3 As Worksheet: Set s3 = Sheets("グラフ貼付2")      
  Dim s4 As Worksheet: Set s4 = Sheets("グラフ貼付2")      
  Dim s5 As Worksheet: Set s5 = Sheets("グラフ貼付2")
  Dim s6 As Worksheet: Set s6 = Sheets("グラフ貼付2")
  Dim s7 As Worksheet: Set s7 = Sheets("グラフ貼付2")
  Dim s8 As Worksheet: Set s8 = Sheets("グラフ貼付2")
  Dim s9 As Worksheet: Set s9 = Sheets("グラフ貼付2")
  Dim s10 As Worksheet: Set s10 = Sheets("グラフ貼付2")
  Dim s11 As Worksheet: Set s11 = Sheets("グラフ貼付2")
  Dim s12 As Worksheet: Set s12 = Sheets("グラフ貼付2")
  Dim s13 As Worksheet: Set s13 = Sheets("グラフ貼付2")
  Dim s14 As Worksheet: Set s14 = Sheets("グラフ貼付2")
  Dim s15 As Worksheet: Set s15 = Sheets("グラフ貼付2")

  Dim s1範囲 As String, s2範囲 As String, s3範囲 As String
  Dim s4範囲 As String, s5範囲 As String, s6範囲 As String
  Dim s7範囲 As String, s8範囲 As String, s9範囲 As String
  Dim s10範囲 As String, s11範囲 As String, s12範囲 As String
  Dim s13範囲 As String, s14範囲 As String, s15範囲 As String

  s1範囲 = Worksheets("マスタ").Range("Q51") & ":" & Worksheets("マスタ").Range("Q51")       
  s2範囲 = Worksheets("マスタ").Range("Q52") & ":" & Worksheets("マスタ").Range("Q52")
  s3範囲 = Worksheets("マスタ").Range("Q53") & ":" & Worksheets("マスタ").Range("Q53")
  s4範囲 = Worksheets("マスタ").Range("Q54") & ":" & Worksheets("マスタ").Range("Q54")
  s5範囲 = Worksheets("マスタ").Range("Q55") & ":" & Worksheets("マスタ").Range("Q55")
  s6範囲 = Worksheets("マスタ").Range("Q56") & ":" & Worksheets("マスタ").Range("Q56")
  s7範囲 = Worksheets("マスタ").Range("Q57") & ":" & Worksheets("マスタ").Range("Q57")
  s8範囲 = Worksheets("マスタ").Range("Q58") & ":" & Worksheets("マスタ").Range("Q58")
  s9範囲 = Worksheets("マスタ").Range("Q59") & ":" & Worksheets("マスタ").Range("Q59")
  s10範囲 = Worksheets("マスタ").Range("Q60") & ":" & Worksheets("マスタ").Range("Q60")
  s11範囲 = Worksheets("マスタ").Range("Q61") & ":" & Worksheets("マスタ").Range("Q61")
  s12範囲 = Worksheets("マスタ").Range("Q62") & ":" & Worksheets("マスタ").Range("Q62")
  s13範囲 = Worksheets("マスタ").Range("Q63") & ":" & Worksheets("マスタ").Range("Q63")
  s14範囲 = Worksheets("マスタ").Range("Q64") & ":" & Worksheets("マスタ").Range("Q64")
  s15範囲 = Worksheets("マスタ").Range("Q65") & ":" & Worksheets("マスタ").Range("Q65")

   '各要素をコレクションにセット
  'オブジェクト名(S1), スライド番号(2), 上からの位置(50), 左からの位置(5), 横幅(400), 順番(0→最前面 1→最背面) の順で
  Call SetProp(s1.Range(s1範囲), 5, 50, 2, 700, 1)          
  Call SetProp(s2.Range(s2範囲), 6, 50, 2, 700, 1)         
  Call SetProp(s4.Range(s4範囲), 8, 50, 2, 700, 1)
  Call SetProp(s5.Range(s5範囲), 9, 50, 4, 700, 1)

  Call SetProp(s6.Range(s6範囲), 10, 52, 5, 700, 1)
  Call SetProp(s7.Range(s7範囲), 11, 52, 5, 700, 1)
  Call SetProp(s8.Range(s8範囲), 12, 50, 5, 700, 1)      
  Call SetProp(s9.Range(s9範囲), 13, 50, 5, 700, 1)

  Call SetProp(s10.Range(s10範囲), 17, 50, 5, 700, 1)       
  Call SetProp(s11.Range(s11範囲), 18, 50, 5, 700, 1)
  Call SetProp(s12.Range(s12範囲), 19, 50, 5, 700, 1)
  Call SetProp(s13.Range(s13範囲), 20, 50, 5, 700, 1)
  Call SetProp(s14.Range(s14範囲), 21, 50, 5, 700, 1)
  Call SetProp(s15.Range(s15範囲), 22, 50, 5, 700, 1)

  Call PowerPointを起動してプレゼンテーションを開く

  'PPTに各要素を貼り付け、後処理
   'PPTの準備
  On Error GoTo ERROR_HANDLER
  Dim ppApp As Object: Set ppApp = CreateObject("PowerPoint.Application") 'PPTアプリ
  Dim pp As Object: Set pp = ppApp.ActivePresentation 'PPTプレゼン
  Dim ppSld As Object 'PPTスライド

  Dim Obj As Class1
  For Each Obj In Objs 'Objsコレクションをループ
    Obj.Name.CopyPicture xlScreen, xlPicture '指定オブジェクトをクリップボードにコピー
    Set ppSld = pp.Slides(Obj.SldNmb) 'PowerPointスライド指定
    ppSld.Shapes.Paste '貼り付け

    '位置・サイズを補正
    With ppSld.Shapes(ppSld.Shapes.Count) '最終シェイプを指定
      .LockAspectRatio = msoTrue '縦横比固定
      .Top = Obj.Top '上からの位置
      .Left = Obj.Left '左からの位置
      .Width = Obj.Width '横幅
      .ZOrder Obj.Odr '移動
      .Height = 330  '重要　表の高さを調節

    End With
  Next

TERMINATE:

  On Error GoTo 0
  Set ppApp = Nothing
  Set pp = Nothing
  Set ppSld = Nothing
  Set Objs = New Collection
  Exit Sub

ERROR_HANDLER:

  MsgBox Err.Description, vbCritical
  Resume TERMINATE
End Sub

（みゆき） 2018/03/30(金) 11:55

 SetPropとクラスモジュールClass1の中身がが分からないのですが・・。
 提示いただくことはできますか？
（ろっくん） 2018/03/30(金) 12:47

ろっくんさん　申し訳ありません。了解しました。

'Class1

Public Name As Object 'オブジェクト名
Public SldNmb As Integer 'スライド番号
Public Top As Integer '上からの位置
Public Left As Integer '左からの位置
Public Width As Integer '横幅
Public Odr As Integer '順番 0→最前面 1→最背面

Property Get Self() As Class1

  Set Self = Me '自己参照
End Property

以上です。よろしくお願いします。

（みゆき） 2018/04/02(月) 08:52

 年度の切り替わりで本業が忙しく、レスポンスが悪くてすみません。

 変わらずSetPropが分かりませんが、現状はこちらの環境(Win7/Excel2010/PowerPoint2010)で再現できません。
 また、PPを閉じるコードがないとか簡略化できそうなところがあるなど気になるところはありますが、
 パッと見でおかしな挙動をするようなコードは見受けられません。

 Set Shp = PP_Sld.Shapes.AddOLEObject(Left:=100, Top:=100, Width:=250, Height:=100, Filename:=InsertFileName, _
        DisplayAsIcon:=True, IconFileName:="C:\Program Files\Microsoft Office\Office14\EXCEL.EXE", _
        Link:=msoTrue, IconLabel:=InsertFileName)
 のIconFileNameのパスに誤りがないか確かめてみてください。
（ろっくん） 2018/04/03(火) 12:44

ろっくんさん　お忙しいところ恐れ入ります。

＞IconFileNameのパスに誤りがないか確かめてみてください。

＞"C:\Program Files\Microsoft Office\Office14\EXCEL.EXE"

確認しましたが　誤りはありません。

●（TEST5）のマクロのみを実行すればエラーはでませんでした。

お手数をおかけしました。今後ともよろしくお願いします。

（みゆき） 2018/04/03(火) 16:13

ろっくんさん　エラーの原因がわかりました。
マクロの記述ミスでした。
問題は、解決しました。申し訳ありません。
エラーがでなくなりました。
ご教授頂き有難うございました。
今後ともよろしくお願いします。
（みゆき） 2018/04/05(木) 16:33

 無事解決されたようでなによりです(^-^)
（ろっくん） 2018/04/05(木) 16:39

コメント返信：

[ 一覧(最新更新順) ]

[[20180228101029]] 『（PowerPoint）のスライドにEXCELファイルを添付ａx（みゆき） ページの最後に飛ぶ

[[20180228101029]]　『（PowerPoint）のスライドにEXCELファイルを添付ａx（みゆき）　ページの最後に飛ぶ