(Excel VBA)Power Point 自動作成で超効率化(基礎)

みなさんこんにちは！ 

独学ですが、ここまできました！

下にサンプルコード記載していますので、参考にしてみてください^^

■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■ 

Option Explicit

Sub mkPpt()

Dim myWs As Worksheet, numDate As Long

Set myWs = ThisWorkbook.Worksheets("報告") '本sheetをセット

numDate = myWs.Cells(16, 2).Value

Dim ppApp As New PowerPoint.Application

Dim ppPrs As PowerPoint.Presentation

Set ppPrs = ppApp.Presentations.Open(ThisWorkbook.Path & "\パワポ.pptx")

Dim ppSld As PowerPoint.Slide 'スライドオブジェクト

Dim pic As PowerPoint.Shape

ppApp.Visible = True

'■■■■■■1ページ目■■■■■■

Set ppSld = ppPrs.Slides(1) '1ページ目のスライドをセット

ppSld.Shapes("ReportDate").TextFrame.TextRange.Text _

                        = Format(numDate, "'yy/m/d(aaa)") & "報告"

ppSld.Shapes("TextBox1").TextFrame.TextRange.Text = myWs.Cells(14, 4) & " " & myWs.Cells(15, 4)

Range(myWs.Cells(1, 1), myWs.Cells(13, 6)).CopyPicture xlScreen, xlPicture 'グラフを画像としてコピー

Set pic = ppSld.Shapes.Paste.PlaceholderFormat.Parent

    pic.Name = "図1"

    pic.Top = 90

    pic.Left = 50

    pic.Width = 600

    pic.ZOrder msoSendToBack '最背面

'■■■■■■2ページ目■■■■■■

Set ppSld = ppPrs.Slides(2) '2ページ目のスライドをセット

ppSld.Shapes("ReportDate").TextFrame.TextRange.Text _

                        = Format(numDate, "'yy/m/d(aaa)") & "報告"

ppSld.Shapes("TextBox1").TextFrame.TextRange.Text = myWs.Cells(14, 11) & " " & myWs.Cells(15, 11)

Range(myWs.Cells(1, 8), myWs.Cells(13, 13)).CopyPicture xlScreen, xlPicture 'グラフを画像としてコピー

Set pic = ppSld.Shapes.Paste.PlaceholderFormat.Parent

    pic.Name = "図1"

    pic.Top = 90

    pic.Left = 50

    pic.Width = 600

    pic.ZOrder msoSendToBack '最背面

'■■■■■■3ページ目■■■■■■

Set ppSld = ppPrs.Slides(3) '3ページ目のスライドをセット

ppSld.Shapes("ReportDate").TextFrame.TextRange.Text _

                        = Format(numDate, "'yy/m/d(aaa)") & "報告"

ppSld.Shapes("TextBox1").TextFrame.TextRange.Text = myWs.Cells(14, 18) & " " & myWs.Cells(15, 18)

Range(myWs.Cells(1, 15), myWs.Cells(13, 20)).CopyPicture xlScreen, xlPicture 'グラフを画像としてコピー

Set pic = ppSld.Shapes.Paste.PlaceholderFormat.Parent

    pic.Name = "図1"

    pic.Top = 90

    pic.Left = 50

    pic.Width = 600

    pic.ZOrder msoSendToBack '最背面

'■■■■■■終了手続き■■■■■■

Application.DisplayAlerts = False

ppPrs.SaveAs ThisWorkbook.Path & "\パワポ_" & Format(numDate, "yyyymmdd") & ".pptx"

Application.DisplayAlerts = True

'ppApp.Quit

MsgBox "そいや、" & vbLf & "幅：" & ppPrs.PageSetup.SlideWidth _

& vbLf & "高さ：" & ppPrs.PageSetup.SlideHeight & vbLf & "です!", vbInformation

Application.CutCopyMode = False

End Sub