[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『Excel表をPowerPointスライド一枚一枚に貼るVBA』(さかき)
お世話になります。よろしくお願いします。
Sheet1に文字が並んだ表があります。例としまして、
A1に○○計画1 A2に○○計画2 A3に今後の展開
などなど。 これはPowerPointのスライドのサブタイトルになります。 これを既存のPowerPointのスライドにテキストボックスで貼り付けたいと 思っております。
そのため、以下のページを参考にしました。
鵜原パソコンソフト研究所 様 http://excel-ubara.com/excelvba5/EXCELVBA254.html
貼り付けをテキストにして貼り付け位置を変えたりは出来たのですが、 複数スライドにペーストすることが出来ません。
1セルずつコピーして1スライドずつペーストしていくことはできるのでしょうか?
ご指導いただけますよう、お願いいたします。
< 使用 Excel:Excel2010、使用 OS:Windows7 >
'★追加変更部分(2007環境) Dim ppApp As New PowerPoint.Application Dim ppPt As Presentation Dim ppSlide As Slide Dim ppShape As PowerPoint.Shape Dim ws As Worksheet Dim rg As Range 'コピー範囲★ Dim p As Long 'スライド数カウンタ★ ppApp.Visible = True 'PowerPoint2007以前の場合は有効にしてください。 Set ppPt = ppApp.Presentations.Open(ThisWorkbook.Path & "\sample.pptx") Set ws = ThisWorkbook.Worksheets("Sheet1") Set rg = ws.Range("A1") '★ With ws For p = 1 To ppPt.Slides.Count '★ rg.Copy '★ 'PasteSpeciaでエラーが出るときは、ここに待ちを作ります。 'スライド番号を指定 Set ppSlide = ppPt.Slides(p) '★ ppSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile, Link:=msoFalse Set ppShape = ppSlide.Shapes(ppSlide.Shapes.Count) '上位置 ppShape.Top = Application.CentimetersToPoints(1) '左位置 ppShape.Left = Application.CentimetersToPoints(1) '縦横比を固定 ppShape.LockAspectRatio = msoTrue '横幅 ppShape.Width = Application.CentimetersToPoints(30) Application.CutCopyMode = False Set rg = rg.Offset(1) '★ Next p '★ End With ppPt.Save ppApp.Quit Set ppPt = Nothing Set ppApp = Nothing End Sub (mm) 2016/04/19(火) 16:58
ありがとうございます!無事に出来ました!!
ppPt.SlidesにCount、自分がやったときは出来なかったです。 きっとどこかを間違って書いていたのですね。
これで80スライドもあるファイル10個を一つ一つコピペする手間がなくなりました。 本当にありがとうございました。 (さかき) 2016/04/19(火) 17:29
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.