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

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

ただいまの
回答率

88.20%

PowerPointの複数結合で背景、デザインもコピーをするVBA

解決済

回答 1

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 1,056

phoenix11

score 5

VBAの全くの素人です。
https://teratail.com/questions/12442こちらのサイトをみてPowerPointの結合のマクロを実行することができました。
複数の結合で、いろいろな背景色であったりデザインで一緒にコピーしたいのですが
わかりませんでした。以下のVBAにどのように入れたら良いでしょうか?
イメージとしては、PowerPointから新しいスライド→スライドの再利用→元の書式を保持するということを、自動化したいのです。
よろしくお願いします。
PowerPointの2013 windows8.1で実施しています。

Sub 結合のマクロ()
    Dim openFilePath As String
    Dim fn As String
    Dim f As Object
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim myPtt As Presentation

    'C:\Users\Windows User\Desktop\PowerPointのマクロ
    Set myPtt = ActivePresentation

    '検索フォルダ
    openFilePath = "C:\Users\Windows User\Desktop\PowerPointの元"

    'フォルダ内のファイルを取得
    For Each f In FSO.GetFolder(openFilePath).Files

      'ファイル名の取得
      fn = f.Name

      '拡張子 pptx で判別
      If FSO.GetExtensionName(openFilePath & "\" & fn) = "pptx" Then

        'コピー元ファイルを開く
        Presentations.Open (openFilePath & "\" & fn)

        With ActivePresentation
          'コピー元から全スライドをコピー
              Presentations(fn).Slides(1).Copy '←スライド1のみコピー。
          'コピー元を閉じる
          .Close
        End With

        'コピー先へ貼り付け
        myPtt.Slides.Paste

      End If

    Next f

    Set FSO = Nothing

End Sub



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

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

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

    クリップを取り消します

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

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

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

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

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

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

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

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

    質問の評価を下げる

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

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

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

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

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

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

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

    詳細な説明はこちら

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

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

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

質問への追記・修正、ベストアンサー選択の依頼

  • meg_

    2020/01/14 20:37

    ・コードは「コードの挿入」で記入してください。
    ・”ここのサイトをみて”とはどのサイトですか?

    キャンセル

  • phoenix11

    2020/01/15 18:44

    ありがとうございます。編集しました。よろしくお願いします。

    キャンセル

回答 1

checkベストアンサー

0

下記サイトが参考になりそうです。

スライドをコピーして新規プレゼンテーションを作成するパワポマクロ

下記が書式のコピー部分です。

With prs_new.Slides.Paste
  .Design = sld_org.Design
  .ColorScheme = sld_org.ColorScheme
  .DisplayMasterShapes = sld_org.DisplayMasterShapes
  .FollowMasterBackground = sld_org.FollowMasterBackground
End With

どうでしょうか?


【追記】下記でどうでしょうか?(質問のコードの抜粋の修正版です)

'フォルダ内のファイルを取得
For Each f In FSO.GetFolder(openFilePath).Files

    'ファイル名の取得
    fn = f.Name

    '拡張子 pptx で判別
    If FSO.GetExtensionName(openFilePath & "\" & fn) = "pptx" Then

        'コピー元ファイルを開く
        Presentations.Open (openFilePath & "\" & fn)
        set sld_org = ActivePresentation.Slides(1) 'スライド1を指定
        sld_org.Copy

        'コピー先へ貼り付け
        With myPtt.Slides.Paste
            .Design = sld_org.Design
            .ColorScheme = sld_org.ColorScheme
            .DisplayMasterShapes = sld_org.DisplayMasterShapes
            .FollowMasterBackground = sld_org.FollowMasterBackground
        End With
    End If
Next f

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/01/16 20:26

    ありがとうございます。本当に素人で申し訳ないのですが、最初に記載した
    最初に記載したコードの sub結合マクロ ~ End Sub
    のどこの部分に上記コード with prs_new・・・・End withを入れたら良いのでしょうか?
    色々と試しましたが、デバッグになったり、エラーになったりしてできません。

    キャンセル

  • 2020/01/18 17:18

    もう少し時間をください。確認はしていますが、なかなか難しくご迷惑おかけし申し訳ございません。

    キャンセル

  • 2020/01/18 18:04

    ありがとうございます。解決できました。

    キャンセル

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

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

関連した質問

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