人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

パワーポイントの最初のページに、○○株式会社御中 という文字があります。
この ○○株式会社 という部分をエクセルのシートの例えばA列にずらっと並んだ文書を自動的にコピペして、列の数分だけパワーポイント文書を作成し、それぞれ保存するマクロというのは作れますでしょうか。

●質問者: clinejp
●カテゴリ:コンピュータ インターネット
✍キーワード:エクセル コピペ パワーポイント マクロ 作成
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● airplant
●35ポイント ベストアンサー

PowerPointが手元にないので動作確認できませんが、プログラム上は掲載したマクロで要望のことが実現できるはずです。

エラーが出たら、すみません。コメント欄にてやり取りしたいと思います。


参照設定というものが必要なので、Excel側のVBEで「ツール」→「参照設定」でパワーポイントのライブラリをつけてください。

オリジナルの入れ替え対象文字、元pptディレクトリ・ファイル名、会社名記載列は、適宜変更ください。

'参照設定 Microsoft Powerpoint ? Object Library が必要
Option Explicit

Const sOrgCorp As String = "○○株式会社"
Const sOrgPPT As String = "C:\プレゼン資料\Original.ppt"

Sub DupPPT()

 Dim rngPPTfile As Range
 Dim sNewPPT As String
 Dim oPPT As Object
 
 Set oPPT = CreateObject("PowerPoint.Application")
 oPPT.Visible = True
 
 Range("A1").Select
 For Each rngPPTfile In Selection.CurrentRegion
 sNewPPT = rngPPTfile.Value
 Set oPresen = oPPT.Presentations.Open(sOrgPPT)
 Call ReplaceText(sOrgCorp, sNewPPT)
 oPresen.SaveAs sNewPPT
 oPresen.Close
 Set oPresen = Nothing
 Next
 oPPT.Quit

End Sub

Sub ReplaceText(sFrom As String, sTo As String)
 
 Dim oSld As Slide
 Dim oShp As Shape
 Dim oTxtRng As TextRange
 Dim oTmpRng As TextRange

 Set oSld = Application.ActivePresentation.Slides(1)

 For Each oShp In oSld.Shapes
 Set oTxtRng = oShp.TextFrame.TextRange
 Set oTmpRng = oTxtRng.Replace(FindWhat:=sFrom, _
 Replacewhat:=sTo)
 Do While Not oTmpRng Is Nothing
 Set oTxtRng = oTxtRng.Characters(oTmpRng.Start + oTmpRng.Length, _
 oTxtRng.Length)
 Set oTmpRng = oTxtRng.Replace(FindWhat:=sFrom, _
 Replacewhat:=sTo)
 Loop
 Next oShp

End Sub

http://q.hatena.ne.jp/1157507418


2 ● airplant
●35ポイント

掲載したものにはバグがあり、動きませんでした。

動作確認した動くバージョンを再度アップします。

なお、動作確認したところ、先頭ページのみを変更する仕様でした。間違いを記載してすみませんでした。

'参照設定 Microsoft Powerpoint ? Object Library が必要
Option Explicit

Const sOrgCorp As String = "○○株式会社"
Const sOrgPPT As String = "C:\プレゼン資料\Original.ppt"
Dim oPresen As Object  '定義抜け

Sub DupPPT()

 Dim rngPPTfile As Range
 Dim sNewPPT As String
 Dim oPPT As Object
 
 Set oPPT = CreateObject("PowerPoint.Application")
 oPPT.Visible = True
 
 Range("A1").Select
 For Each rngPPTfile In Selection.CurrentRegion
 sNewPPT = rngPPTfile.Value
 Set oPresen = oPPT.Presentations.Open(sOrgPPT)
 Call ReplaceText(sOrgCorp, sNewPPT)
 oPresen.SaveAs CurDir & "\" & sNewPPT  '修正(フォルダを記載しないとなぜかC:\Windows\Win32にできる)
 oPresen.Close
 Set oPresen = Nothing
 Next
 oPPT.Quit

End Sub

Sub ReplaceText(sFrom As String, sTo As String)
 
 Dim oSld As Slide
' Dim oShp As Shape '修正
 Dim oShp As Object
 Dim oTxtRng As TextRange
 Dim oTmpRng As TextRange

 Set oSld = oPresen.Slides(1)  '修正

 For Each oShp In oSld.Shapes
 Set oTxtRng = oShp.TextFrame.TextRange
 Set oTmpRng = oTxtRng.Replace(FindWhat:=sFrom, _
 Replacewhat:=sTo)
 Do While Not oTmpRng Is Nothing
 Set oTxtRng = oTxtRng.Characters(oTmpRng.Start + oTmpRng.Length, _
 oTxtRng.Length)
 Set oTmpRng = oTxtRng.Replace(FindWhat:=sFrom, _
 Replacewhat:=sTo)
 Loop
 Next oShp

End Sub

http://www.google.co.jp (ダミー)

◎質問者からの返答

ありがとうございます。

C:\プレゼン資料\Original.ppt

にダミーデータを作っているのですが、下記のところでエラーが出ます。

何か考えられる原因はありますでしょうか。

oPresen.SaveAs CurDir & "\" & sNewPPT '修正(フォルダを記載しないとなぜかC:\Windows\Win32にできる)

エラーの内容は

「PresentationSaveAs:無効な要求です。無効なファイル名です」

となります。

コメントいただけると幸いです。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ