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

Question

我有一个宏，它基本上应该从 excel 电子表格中复制范围，然后将它们粘贴到 powerpoint 文件中。所以每张幻灯片一张 Excel 表。

到目前为止，这是我的宏：

    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

当我运行宏时，它会打开 PowerPoint，但会停止并出现以下错误：

当我调试时它停在这一行：

Set PPSlide = PPAPP.ActivePresentation.Slides(SlideNum)

任何关于如何解决这个问题的帮助都会很棒。

Answer 1

错误指向您在代码中引入的计数问题。显然，在第一次迭代期间，它尝试选择单张幻灯片演示的第二张幻灯片（第二张幻灯片不存在）并引发错误。

我认为这是因为您的 SlideOffset 变量而发生的。考虑在运行Set PPSlide = PPAPP.ActivePresentation.Slides(SlideNum) 之前先添加一张幻灯片。像这样的：

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

Answer 2

试试这个

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