Sub パワーポイントへタイトルと本文を挿入する()
Dim objPPTApp As Object
Dim objPPTPres As Object
Dim objPPTSlide As Object
Dim objPPTLayout As Object
Dim intlastRow As Integer
Dim i As Integer
Dim SlideNum As Integer
Dim Title As String
Dim Body As String
'Excel台帳の1スライド目を設定します。
With ThisWorkbook.Worksheets(1)
' PowerPointアプリケーションをセットします。
Set objPPTApp = CreateObject("PowerPoint.Application")
'Excel台帳のG1セルを元にPowerPointファイルを開きます。
Set objPPTPres = objPPTApp.Presentations.Open(.Range("G1").Value)
' PowerPointアプリケーションを表示します。
objPPTApp.Visible = True
'ファイルパスを格納する列の範囲を取得します。
intlastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'Excel台帳の最終行数分処理を繰り返します。
For i = 2 To intlastRow
'Excel台帳側に入力されているタイトルと本文を取得します。
SlideNum = .Cells(i, 1).Value
Title = .Cells(i, 2).Value
Body = .Cells(i, 3).Value
'PowerPointにスライドを加えるか、既存スライドを使うか判定します。
If SlideNum > objPPTPres.Slides.Count Then
'PowerPointにスライドを加えます。
Set objPPTLayout = objPPTPres.Slides(2).CustomLayout
Set objPPTSlide = objPPTPres.Slides.AddSlide(SlideNum, objPPTLayout)
Else
'PowerPointの既存スライドを使います。
Set objPPTSlide = objPPTPres.Slides(SlideNum)
End If
'スライドにタイトルと本文を挿入します。
objPPTSlide.Shapes(1).TextFrame.TextRange.Text = Title
objPPTSlide.Shapes(2).TextFrame.TextRange.Text = Body
Next i
End With
'オブジェクトを開放します。
Set objPPTApp = Nothing
Set objPPTPres = Nothing
Set objPPTSlide = Nothing
Set objPPTLayout = Nothing
MsgBox "Excel台帳からパワーポイントへタイトルと本文を挿入しました！" & Chr(10) & "OKであれば保存してください。"
End Sub
コメントを残す