无法使用宏将数据从Excel复制到PPT

Question

I have a macro that basically is supposed to copy ranges from excel spreadsheets and then paste them into a powerpoint file. So one excel sheet per slide.

Here is my macro so far:

    Option Explicit

    Sub ExportToPPT()
     Dim PPAPP As PowerPoint.Application
    Dim PPRES As PowerPoint.Presentation
    Dim PPSlide As PowerPoint.Slide
    Dim ppSRng As PowerPoint.ShapeRange

    Dim XLAPP As Excel.Application
    Dim XLwbk As Excel.Workbook
    Dim xlWst As Excel.Worksheet
    Dim XLRng As Excel.Range

    Dim ppPathFile As String
    Dim ppNewPathFile

    Dim chartNum As Integer
    Dim maxCharts As Integer

    Debug.Print vbCrLf & "    ---- EXPORT EXCEL RANGES POWERPOINT ----"
    Debug.Print Now() & " - Exporting ranges to .ppt"

    'CHANGE WHEN ADDING CHARTS - MUST ALSO ADD SLIDE to .PPT and change loop
    Dim chartRng(1 To 9) As Excel.Range
    Dim SlideNum As Integer
    Dim SlideOffset As Integer

    Set XLwbk = Excel.ActiveWorkbook
    Set xlWst = XLwbk.Sheets("Test1")

        'This accounts for the title slide and any others before the automatedpaste
        SlideOffset = 1
        Set chartRng(1) = XLwbk.Sheets("Test1").Range("A1:B15")
        Set chartRng(2) = XLwbk.Sheets("Test2").Range("A1:E33")
        Set chartRng(3) = XLwbk.Sheets("Test3").Range("A1:E33")
        Set chartRng(4) = XLwbk.Sheets("Test4").Range("A1:E4")
        Set chartRng(5) = XLwbk.Sheets("Test5").Range("A1:J14")
        Set chartRng(6) = XLwbk.Sheets("Test6").Range("A1:I33")
        Set chartRng(7) = XLwbk.Sheets("Test7").Range("A1:I11")
        Set chartRng(8) = XLwbk.Sheets("Test8").Range("A1:I8")


    ' Create instance of PowerPoint
    Set PPAPP = CreateObject("Powerpoint.Application")
        PPAPP.Visible = True

        ' Open the presentation (Same folder as the Excel file)
        ppPathFile = ActiveWorkbook.Path + "TestPPT.pptx"
        Debug.Print ppPathFile
        Set PPRES = PPAPP.Presentations.Open(ppPathFile)

        PPAPP.ActiveWindow.ViewType = ppViewSlide


    chartNum = 1

    'Loop through all chart ranges
    'CHANGE WHEN ADDING CHARTS
    For chartNum = 1 To 9
        SlideNum = chartNum + SlideOffset
        Debug.Print "Chart number " & chartNum & " to slide number " & SlideNum

        ' Copy the range as a picture
         chartRng(chartNum).CopyPicture Appearance:=xlScreen, Format:=xlPicture


        'PowerPoint operations
           Set PPSlide = PPAPP.ActivePresentation.AddSlide(1, _ **//New code**
PPAPP.ActivePresentation.SlideMaster.CustomLayouts.Item(2))
            Debug.Print PPSlide.Name
            PPSlide.Select

            PPAPP.ActiveWindow.ViewType = ppViewSlide
            'ppapp.ActivePresentation.Slides.
            ' Paste the range
            'PPAPP.ActiveWindow.View.Slide (SlideNum)
            PPAPP.ActiveWindow.View.Paste

            'PPSlide.Shapes.Paste
            'PPSlide.Shapes(0).Select
            'PPSlide.Shapes.Paste.Select

                ' Align the pasted range
                Set ppSRng = PPAPP.ActiveWindow.Selection.ShapeRange
                With ppSRng
                    .LockAspectRatio = msoTrue
                If (.Width / .Height) > 1.65 Then
                        .Width = 650
                    Else
                        .Height = 400
                    End If
                End With


                With ppSRng
                    '.Width = 650
                    .Align msoAlignCenters, True
                    .Align msoAlignMiddles, True
                    .IncrementTop 1.5
                End With

    Next chartNum

    PPAPP.ActivePresentation.Slides(1).Select
    PPAPP.ActiveWindow.ViewType = ppViewNormal
    PPAPP.Activate

    ppNewPathFile = ActiveWorkbook.Path & "\Test\TestPPT.pptx" & Format(Now(), "yyyymmdd_hhmmss")
    PPAPP.ActivePresentation.SaveAs ppNewPathFile, ppSaveAsDefault

    Debug.Print Now() & " - Finished"

    End Sub

When I run the Macro it opens PowerPoint but stops and I get the following Error:

And when I debug it stops at this line:

Set PPSlide = PPAPP.ActivePresentation.Slides(SlideNum)

Any help on how to fix this would be great guys.

Answer 1

The error points to a counting problem that you've introduced in your code. Apparently, during the first iteration, it attempts to choose the second slide of a one-slide presentation (the second slide does not exist) and throwing an error.

I would assume this occurs because of your SlideOffset variable. Consider first adding a slide using before running Set PPSlide = PPAPP.ActivePresentation.Slides(SlideNum) . Something like this:

Set pptLayout = PPAPP.ActivePresentation.Slides(1).CustomLayout 
Set pptSlide = PPAPP.ActivePresentation.Slides.AddSlide(2, pptLayout)

Answer 2

Try using this

Set PPSlide = PPAPP.ActivePresentation.AddSlide(1,  _
PPAPP.ActivePresentation.SlideMaster.CustomLayouts.Item(2))