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
コードの説明
CopySlidesBasedOnIdentifier
サブルーチンがPowerPointアプリケーションを起動し、指定された転記元および転記先のファイルを開きます。CopySlidesWithIdentifier
サブルーチンが、各転記元ファイルの全スライドをループし、スライド上の識別子に基づいて適切な転記先ファイルにスライドをコピー&ペーストします。- コピー&ペーストする前に、転記先のプレゼンテーションに新しい空白スライドを追加しています。
pptLayoutBlank
(12)は、新しいスライドのレイアウトを空白にする定数です。その後、コピーしたスライドを新しいスライドに貼り付けます。 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