質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

88.23%

エクセルからグループ化した図形をパワーポイントに貼り付けたい

受付中

回答 0

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 789

Minnku

score 4

エクセルで作成したグループ化させた図形(テキスト入力あり)を「元の書式を保持」したまま
パワーポイントのシートの位置や貼付大きさを指定した上で貼り付けがしたいです。

しかし実行すると以下のエラーメッセージが表示さえ、パワーポイントへの貼り付けが行えないです。
原因と対処方法を教えてほしいです。

発生している問題・エラーメッセージ

オブジェクトは、このプロパティまたはメソッドをサポートしていません。

該当のソースコード

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

Property Get Self() As Class1
  Set Self = Me '自己参照
End Property

Function CreateNew(NewName As Object, NewSldNmb As Integer, NewTop As Integer, _
                   NewLeft As Integer, NewWidth As Integer, NewOdr As Integer) As Class1
  With New Class1
    Set .Name = NewName 'オブジェクト名
    .SldNmb = NewSldNmb 'スライド番号
    .Top = NewTop '上からの位置
    .Left = NewLeft '左からの位置
    .Width = NewWidth '横幅
    .Odr = NewOdr '順番
    Set CreateNew = .Self '作成したインスタンスを返す
  End With
End Function
Sub オートシェイプ一斉貼り付け()
  'コレクション生成
  Dim Objs As Collection: Set Objs = New Collection

  'シート名を変数へセット
  Dim s1 As Worksheet: Set s1 = Sheets("シート1")
  Dim s2 As Worksheet: Set s1 = Sheets("シート2")

  '各要素をコレクションにセット
  'オブジェクト名, スライド番号, 上からの位置, 左からの位置, 横幅, 順番(0→最前面 1→最背面) の順で
  With New Class1
    Objs.Add .CreateNew(s1.Shapes.Range(Array("Group 1")), 2, 50, 10, 600, 0)  
    Objs.Add .CreateNew(s1.Shapes.Range(Array("Group 4")), 2, 50, 10, 600, 0)

    Objs.Add .CreateNew(s2.Shapes.Range(Array("Group 1")), 3, 50, 10, 600, 0)  
    Objs.Add .CreateNew(s2.Shapes.Range(Array("Group 4")), 3, 50, 10, 600, 0)
  End With

  '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 '移動
    End With
  Next

TERMINATE:
  On Error GoTo 0
  Set ppApp = Nothing
  Set pp = Nothing
  Set ppSld = Nothing
  Exit Sub

ERROR_HANDLER:
  MsgBox Err.Description, vbCritical
  Resume TERMINATE
End Sub

補足事項

貼り付け先のパワーポイントは、指定されているスライドがすべて存在していて、既に開いているのが条件です。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

まだ回答がついていません

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 88.23%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る