Sub パワーポイントへExcelの文字列を挿入する()
Dim objPPTApp As PowerPoint.Application
Dim objPPTPres As PowerPoint.Presentation
Dim objPPTSlide As PowerPoint.slide
Dim objPPTShape As PowerPoint.Shape
Dim intlastRow As Integer
Dim i As Integer
Dim micount As Integer
Dim cocount As Integer
'PowerPointアプリケーションをセットします。
Set objPPTApp = CreateObject("PowerPoint.Application")
'Excelの最初のシートを参照します。
With ThisWorkbook.Sheets(1)
' PowerPointのファイルパスを取得します。
Set objPPTPres = objPPTApp.Presentations.Open(.Cells(1, 3).Value)
'列の最終行を取得します。
intlastRow = .Cells(Rows.count, 1).SpecialCells(xlLastCell).row
'Excelシートの各行に対して処理を行います。
For i = 4 To intlastRow
If .Cells(i, 2).Value <> "" Then
'見出しカウント初期化
micount = 0
cocount = 0
' パワーポイントのスライドを取得します。
Set objPPTSlide = objPPTPres.Slides(.Cells(i, 1).Value)
' タイトルを追加します。
Set objPPTShape = objPPTSlide.Shapes.Title
objPPTShape.TextFrame.TextRange.text = .Cells(i, 2).Value
End If
'見出しの処理です。
If .Cells(i, 3).Value <> "" Then
'見出しの数をカウントします。
micount = micount + 1
'テキストボックスを追加します。
Set objPPTShape = objPPTSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 90, 120 * micount, 700, 50)
'テキストボックスに文字を追加します。
objPPTShape.TextFrame.TextRange.text = .Cells(i, 3).Value
'文字を太字にします。
objPPTShape.TextEffect.FontBold = True
'フォントサイズを変更します。
objPPTShape.TextEffect.FontSize = 24
End If
'本文の処理です。
If .Cells(i, 4).Value <> "" Then
'本文の数をカウントします。
cocount = cocount + 1
'テキストボックスを追加します。
Set objPPTShape = objPPTSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 110, (120 * cocount) + 40, 700, 50)
'テキストボックスに文字を追加します。
objPPTShape.TextFrame.TextRange.text = .Cells(i, 4).Value
'フォントサイズを変更します。
objPPTShape.TextFrame.TextRange.Font.Size = 24
End If
Next i
End With
Set objPPTApp = Nothing
Set objPPTPres = Nothing
Set objPPTSlide = Nothing
Set objPPTShape = Nothing
MsgBox "パワーポイントへ文字列を貼り付けました！" & Chr(10) & "OKであれば保存してください。"
End Sub
コメントを残す