PowerPointのページを別のPowerPointに転記する方法

目次

PowerPointのページを別のPowerPointに転記(振り分け)する方法

前提

・転記元のPowerPointのファイルがあらかじめ2つ用意されている。
・転記元のファイル名は「ファイルA」「ファイルB」とする。
・転記元のファイルは、”C:\Path\From”に保存されている。
・転記先のPowerPointのファイルがあらかじめ4つ用意されている。
・転記先のファイル名は「ファイル1」「ファイル2」「ファイル3」「ファイル4」とする。
・転記先のファイルは、”C:\Path\To”に保存されている。
・転記元のファイルA,Bには、転記先のどのファイルにわりふるかを区別するための識別子が記入されている。
・識別子とは「転記先:ファイル1」「転記先:ファイル2」「転記先:ファイル3」「転記先:ファイル4」の文字列である。

やりたいこと

・転記元のファイルの各ページを、各ページに記入された識別子にしたがって、転記先のファイルにコピーペーストする
・転記先のファイルにコピーペーストするときは、まず、転記先のファイルに、ページを作成(挿入)してから、コピーペーストする。
・転記先のファイルは、保存してから閉じる。

サンプルコードは以下のとおり。

Sub CopySlidesBasedOnIdentifier()

    ' PowerPointアプリケーションを宣言して起動
    Dim pptApp As Object
    Set pptApp = CreateObject("PowerPoint.Application")
    
    ' 転記元のファイルを開く
    Dim sourcePath As String
    sourcePath = "C:\Path\From\"
    Dim pptSourceA As Object
    Set pptSourceA = pptApp.Presentations.Open(sourcePath & "ファイルA.pptx")
    
    Dim pptSourceB As Object
    Set pptSourceB = pptApp.Presentations.Open(sourcePath & "ファイルB.pptx")
    
    ' 転記先のファイルを開く
    Dim targetPath As String
    targetPath = "C:\Path\To\"
    Dim pptTarget1 As Object
    Set pptTarget1 = pptApp.Presentations.Open(targetPath & "ファイル1.pptx")
    
    Dim pptTarget2 As Object
    Set pptTarget2 = pptApp.Presentations.Open(targetPath & "ファイル2.pptx")
    
    Dim pptTarget3 As Object
    Set pptTarget3 = pptApp.Presentations.Open(targetPath & "ファイル3.pptx")
    
    Dim pptTarget4 As Object
    Set pptTarget4 = pptApp.Presentations.Open(targetPath & "ファイル4.pptx")
    
    ' スライドをコピーするためのサブルーチンを呼び出す
    Call CopySlidesWithIdentifier(pptSourceA, pptTarget1, pptTarget2, pptTarget3, pptTarget4)
    Call CopySlidesWithIdentifier(pptSourceB, pptTarget1, pptTarget2, pptTarget3, pptTarget4)
    
    ' 転記先のファイルを保存して閉じる
    pptTarget1.Save
    pptTarget2.Save
    pptTarget3.Save
    pptTarget4.Save
    pptTarget1.Close
    pptTarget2.Close
    pptTarget3.Close
    pptTarget4.Close
    
    ' アプリケーションを終了
    pptApp.Quit
    
    ' オブジェクトを解放
    Set pptSourceA = Nothing
    Set pptSourceB = Nothing
    Set pptTarget1 = Nothing
    Set pptTarget2 = Nothing
    Set pptTarget3 = Nothing
    Set pptTarget4 = Nothing
    Set pptApp = Nothing

End Sub

Sub CopySlidesWithIdentifier(pptSource As Object, pptTarget1 As Object, pptTarget2 As Object, pptTarget3 As Object, pptTarget4 As Object)
    
    Dim slide As Object
    Dim identifier As String
    Dim targetPresentation As Object
    
    ' 転記元の全スライドをループする
    For Each slide In pptSource.Slides
        ' スライドの識別子を取得する
        identifier = GetIdentifierFromSlide(slide)
        
        ' 識別子に基づいて転記先のファイルを選択する
        Select Case identifier
            Case "転記先:ファイル1"
                Set targetPresentation = pptTarget1
            Case "転記先:ファイル2"
                Set targetPresentation = pptTarget2
            Case "転記先:ファイル3"
                Set targetPresentation = pptTarget3
            Case "転記先:ファイル4"
                Set targetPresentation = pptTarget4
            Case Else
                ' 識別子がない場合はスキップ
                GoTo NextSlide
        End Select
        
        ' 転記先に新しいスライドを挿入
        targetPresentation.Slides.Add targetPresentation.Slides.Count + 1, 12 ' ppLayoutBlank = 12
        
        ' スライドをコピーして転記先に貼り付け
        slide.Copy
        targetPresentation.Slides.Paste (targetPresentation.Slides.Count)
        
NextSlide:
    Next slide

End Sub

Function GetIdentifierFromSlide(slide As Object) As String
    Dim shape As Object
    Dim text As String
    
    ' スライド上の全てのシェイプをループする
    For Each shape In slide.Shapes
        ' シェイプがテキストを含む場合
        If shape.HasTextFrame Then
            text = shape.TextFrame.TextRange.Text
            ' 識別子が含まれているかチェック
            If InStr(text, "転記先:") > 0 Then
                GetIdentifierFromSlide = text
                Exit Function
            End If
        End If
    Next shape
    
    ' 識別子が見つからない場合は空文字を返す
    GetIdentifierFromSlide = ""
End Function

コードの説明

  1. CopySlidesBasedOnIdentifierサブルーチンがPowerPointアプリケーションを起動し、指定された転記元および転記先のファイルを開きます。
  2. CopySlidesWithIdentifierサブルーチンが、各転記元ファイルの全スライドをループし、スライド上の識別子に基づいて適切な転記先ファイルにスライドをコピー&ペーストします。
  3. コピー&ペーストする前に、転記先のプレゼンテーションに新しい空白スライドを追加しています。pptLayoutBlank(12)は、新しいスライドのレイアウトを空白にする定数です。その後、コピーしたスライドを新しいスライドに貼り付けます。
  4. GetIdentifierFromSlide関数が、スライド内のテキストシェイプを検索し、識別子を抽出します。

転記先の識別子を削除したい場合も以下に紹介します。

やりたいこと

・上記のマクロの実行が完了した後、転記先のファイルの中に記載された識別子を全て削除して、保存する。

サンプルコードは以下のとおり。

Sub RemoveIdentifiersAll ()

    ' PowerPointアプリケーションを宣言して起動
    Dim pptApp As Object
    Set pptApp = CreateObject("PowerPoint.Application")

    ' 転記先のファイルを開く
    Dim targetPath As String
    targetPath = "C:\Path\To\"
    Dim pptTarget1 As Object
    Set pptTarget1 = pptApp.Presentations.Open(targetPath & "ファイル1.pptx")
    
    Dim pptTarget2 As Object
    Set pptTarget2 = pptApp.Presentations.Open(targetPath & "ファイル2.pptx")
    
    Dim pptTarget3 As Object
    Set pptTarget3 = pptApp.Presentations.Open(targetPath & "ファイル3.pptx")
    
    Dim pptTarget4 As Object
    Set pptTarget4 = pptApp.Presentations.Open(targetPath & "ファイル4.pptx")

    ' 識別子を削除するためのサブルーチンを呼び出す
    Call RemoveIdentifiers(pptTarget1)
    Call RemoveIdentifiers(pptTarget2)
    Call RemoveIdentifiers(pptTarget3)
    Call RemoveIdentifiers(pptTarget4)
    
    ' 再度保存して閉じる
    pptTarget1.Save
    pptTarget2.Save
    pptTarget3.Save
    pptTarget4.Save
    pptTarget1.Close
    pptTarget2.Close
    pptTarget3.Close
    pptTarget4.Close
    
    ' アプリケーションを終了
    pptApp.Quit
    
    ' オブジェクトを解放
    Set pptSourceA = Nothing
    Set pptSourceB = Nothing
    Set pptTarget1 = Nothing
    Set pptTarget2 = Nothing
    Set pptTarget3 = Nothing
    Set pptTarget4 = Nothing
    Set pptApp = Nothing

End Sub

Sub RemoveIdentifiers(pptTarget As Object)
    Dim slide As Object
    Dim shape As Object
    Dim text As String
    
    ' 転記先の全スライドをループする
    For Each slide In pptTarget.Slides
        ' スライド上の全てのシェイプをループする
        For Each shape In slide.Shapes
            ' シェイプがテキストを含む場合
            If shape.HasTextFrame Then
                text = shape.TextFrame.TextRange.Text
                ' 識別子を含むテキストを削除
                If InStr(text, "転記先:ファイル1") > 0 Then
                    shape.TextFrame.TextRange.Text = Replace(text, "転記先:ファイル1", "")
                ElseIf InStr(text, "転記先:ファイル2") > 0 Then
                    shape.TextFrame.TextRange.Text = Replace(text, "転記先:ファイル2", "")
                ElseIf InStr(text, "転記先:ファイル3") > 0 Then
                    shape.TextFrame.TextRange.Text = Replace(text, "転記先:ファイル3", "")
                ElseIf InStr(text, "転記先:ファイル4") > 0 Then
                    shape.TextFrame.TextRange.Text = Replace(text, "転記先:ファイル4", "")
                End If
            End If
        Next shape
    Next slide
End Sub

1つのPowerPointを、別の複数のPowerPointに転記(分割)する方法

前提

・転記元のPowerPointのファイルがあらかじめ1つ用意されている。
・転記元のファイル名は「ファイルA」とする。
・転記元のファイルは、”C:\Path\From”に保存されている。
・転記先のPowerPointのファイルがあらかじめ4つ用意されている。
・転記先のファイル名は「ファイル1」「ファイル2」「ファイル3」「ファイル4」とする。
・転記先のファイルは、”C:\Path\To”に保存されている。
・転記元のファイルAには、転記先のどのファイルにわりふるかを区別するための識別子が記入されている。
・識別子とは「転記先:ファイル1」「転記先:ファイル2」「転記先:ファイル3」「転記先:ファイル4」の文字列である。

やりたいこと

・転記元のファイルの各ページを、各ページに記入された識別子にしたがって、転記先のファイルにコピーペーストする
・転記先のファイルにコピーペーストするときは、まず、転記先のファイルに、ページを作成(挿入)してから、コピーペーストする。
・転記先のファイルは、保存してから閉じる。

サンプルコードは以下のとおり。

Sub CopySlidesBasedOnIdentifier()

    ' PowerPointアプリケーションを宣言して起動
    Dim pptApp As Object
    Set pptApp = CreateObject("PowerPoint.Application")
    
    ' 転記元のファイルを開く
    Dim sourcePath As String
    sourcePath = "C:\Path\From\"
    Dim pptSource As Object
    Set pptSource = pptApp.Presentations.Open(sourcePath & "ファイルA.pptx")
    
    ' 転記先のファイルを開く
    Dim targetPath As String
    targetPath = "C:\Path\To\"
    Dim pptTarget1 As Object
    Set pptTarget1 = pptApp.Presentations.Open(targetPath & "ファイル1.pptx")
    
    Dim pptTarget2 As Object
    Set pptTarget2 = pptApp.Presentations.Open(targetPath & "ファイル2.pptx")
    
    Dim pptTarget3 As Object
    Set pptTarget3 = pptApp.Presentations.Open(targetPath & "ファイル3.pptx")
    
    Dim pptTarget4 As Object
    Set pptTarget4 = pptApp.Presentations.Open(targetPath & "ファイル4.pptx")
    
    ' スライドをコピーするためのサブルーチンを呼び出す
    Call CopySlidesWithIdentifier(pptSource, pptTarget1, pptTarget2, pptTarget3, pptTarget4)
    
    ' 転記先のファイルを保存して閉じる
    pptTarget1.Save
    pptTarget1.Close
    
    pptTarget2.Save
    pptTarget2.Close
    
    pptTarget3.Save
    pptTarget3.Close
    
    pptTarget4.Save
    pptTarget4.Close
    
    ' アプリケーションを終了
    pptApp.Quit
    
    ' オブジェクトを解放
    Set pptSource = Nothing
    Set pptTarget1 = Nothing
    Set pptTarget2 = Nothing
    Set pptTarget3 = Nothing
    Set pptTarget4 = Nothing
    Set pptApp = Nothing

End Sub

Sub CopySlidesWithIdentifier(pptSource As Object, pptTarget1 As Object, pptTarget2 As Object, pptTarget3 As Object, pptTarget4 As Object)
    
    Dim slide As Object
    Dim identifier As String
    Dim targetPresentation As Object
    
    ' 転記元の全スライドをループする
    For Each slide In pptSource.Slides
        ' スライドの識別子を取得する
        identifier = GetIdentifierFromSlide(slide)
        
        ' 識別子に基づいて転記先のファイルを選択する
        Select Case identifier
            Case "転記先:ファイル1"
                Set targetPresentation = pptTarget1
            Case "転記先:ファイル2"
                Set targetPresentation = pptTarget2
            Case "転記先:ファイル3"
                Set targetPresentation = pptTarget3
            Case "転記先:ファイル4"
                Set targetPresentation = pptTarget4
            Case Else
                ' 識別子がない場合はスキップ
                GoTo NextSlide
        End Select
        
        ' 転記先に新しいスライドを挿入
        targetPresentation.Slides.Add targetPresentation.Slides.Count + 1, 12 ' ppLayoutBlank = 12
        
        ' スライドをコピーして転記先に貼り付け
        slide.Copy
        targetPresentation.Slides.Paste (targetPresentation.Slides.Count)
        
NextSlide:
    Next slide

End Sub

Function GetIdentifierFromSlide(slide As Object) As String
    Dim shape As Object
    Dim text As String
    
    ' スライド上の全てのシェイプをループする
    For Each shape In slide.Shapes
        ' シェイプがテキストを含む場合
        If shape.HasTextFrame Then
            text = shape.TextFrame.TextRange.Text
            ' 識別子が含まれているかチェック
            If InStr(text, "転記先:") > 0 Then
                GetIdentifierFromSlide = text
                Exit Function
            End If
        End If
    Next shape
    
    ' 識別子が見つからない場合は空文字を返す
    GetIdentifierFromSlide = ""
End Function

複数のPowerPointを1つのPowerPointに転記(マージ)する方法

前提

・転記元のPowerPointのファイルがあらかじめ4つ用意されている。
・転記元のファイル名は「ファイルA」「ファイルB」「ファイルC」「ファイルD」とする。
・転記元のファイルは、”C:\Path\From”に保存されている。
・転記先のPowerPointのファイルがあらかじめ1つ用意されている。
・転記先のファイル名は「ファイル1」とする。
・転記先のファイルは、”C:\Path\To”に保存されている。
・転記先のファイルは、目次用に4ページ用意されている。各ページには、「目次1」「目次2」「目次3」「目次4」と記載されている。
・転記元のファイルA,B,C,Dの各ページには、転記先のファイルのどの目次にわりふるかの識別子が記入されている。識別子とは「転記先:目次1」「転記先:目次2」「転記先:目次3」「転記先:目次4」の文字列である。

やりたいこと

・転記元のファイルの各ページを、各ページに記入された識別子にしたがって、転記先のファイルにコピーペーストする。
・転記先のファイルにコピーペーストするときは、まず、転記先のファイルに、ページを作成(挿入)してから、コピーペーストする。
・転記先のファイルは、保存してから閉じる。

サンプルコードは以下のとおり。

Sub CopySlidesBasedOnIdentifier()

    ' PowerPointアプリケーションを宣言して起動
    Dim pptApp As Object
    Set pptApp = CreateObject("PowerPoint.Application")
    
    ' 転記元のファイルを開く
    Dim sourcePath As String
    sourcePath = "C:\Path\From\"
    Dim pptSourceA As Object
    Set pptSourceA = pptApp.Presentations.Open(sourcePath & "ファイルA.pptx")
    
    Dim pptSourceB As Object
    Set pptSourceB = pptApp.Presentations.Open(sourcePath & "ファイルB.pptx")
    
    Dim pptSourceC As Object
    Set pptSourceC = pptApp.Presentations.Open(sourcePath & "ファイルC.pptx")
    
    Dim pptSourceD As Object
    Set pptSourceD = pptApp.Presentations.Open(sourcePath & "ファイルD.pptx")
    
    ' 転記先のファイルを開く
    Dim targetPath As String
    targetPath = "C:\Path\To\"
    Dim pptTarget As Object
    Set pptTarget = pptApp.Presentations.Open(targetPath & "ファイル1.pptx")
    
    ' スライドをコピーするためのサブルーチンを呼び出す
    Call CopySlidesWithIdentifier(pptSourceA, pptTarget)
    Call CopySlidesWithIdentifier(pptSourceB, pptTarget)
    Call CopySlidesWithIdentifier(pptSourceC, pptTarget)
    Call CopySlidesWithIdentifier(pptSourceD, pptTarget)
    
    ' 転記先のファイルを保存して閉じる
    pptTarget.Save
    pptTarget.Close
    
    ' アプリケーションを終了
    pptApp.Quit
    
    ' オブジェクトを解放
    Set pptSourceA = Nothing
    Set pptSourceB = Nothing
    Set pptSourceC = Nothing
    Set pptSourceD = Nothing
    Set pptTarget = Nothing
    Set pptApp = Nothing

End Sub

Sub CopySlidesWithIdentifier(pptSource As Object, pptTarget As Object)
    
    Dim slide As Object
    Dim identifier As String
    Dim targetSlideIndex As Integer
    
    ' 転記元の全スライドをループする
    For Each slide In pptSource.Slides
        ' スライドの識別子を取得する
        identifier = GetIdentifierFromSlide(slide)
        
        ' 識別子に基づいて転記先のスライドのインデックスを決定する
        Select Case identifier
            Case "転記先:目次1"
                targetSlideIndex = 1
            Case "転記先:目次2"
                targetSlideIndex = 2
            Case "転記先:目次3"
                targetSlideIndex = 3
            Case "転記先:目次4"
                targetSlideIndex = 4
            Case Else
                ' 識別子がない場合はスキップ
                GoTo NextSlide
        End Select
        
        ' 転記先に新しいスライドを挿入
        pptTarget.Slides.Add pptTarget.Slides.Count + 1, 12 ' ppLayoutBlank = 12
        
        ' スライドをコピーして転記先に貼り付け
        slide.Copy
        pptTarget.Slides.Paste (pptTarget.Slides.Count)
        
        ' 新しく挿入されたスライドを適切な位置に移動
        pptTarget.Slides(pptTarget.Slides.Count).MoveTo (targetSlideIndex + 1)
        
NextSlide:
    Next slide

End Sub

Function GetIdentifierFromSlide(slide As Object) As String
    Dim shape As Object
    Dim text As String
    
    ' スライド上の全てのシェイプをループする
    For Each shape In slide.Shapes
        ' シェイプがテキストを含む場合
        If shape.HasTextFrame Then
            text = shape.TextFrame.TextRange.Text
            ' 識別子が含まれているかチェック
            If InStr(text, "転記先:") > 0 Then
                GetIdentifierFromSlide = text
                Exit Function
            End If
        End If
    Next shape
    
    ' 識別子が見つからない場合は空文字を返す
    GetIdentifierFromSlide = ""
End Function
よかったらシェアしてね!
  • URLをコピーしました!
  • URLをコピーしました!
目次