Question

编写了一个宏，需要将我的数据从我的Excel工作簿复制为以powerpoint演示文稿为中心的图像。

到目前为止，它正确地复制了一张，但随后出错了，我收到错误：'运行时错误'424：对象必需'在行： .Shapes.Paste.Select

这是我的代码：

如何解决这个问题的任何帮助将不胜感激：

Sub export()

    Dim PPAPP As PowerPoint.Application
    Dim PPRES As PowerPoint.Presentation
    Dim PPSlide As PowerPoint.Slide
    Dim ppSRng As PowerPoint.ShapeRange

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

    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"

    ' For automation to work, PowerPoint must be visible
    ' (alternatively, other extraordinary measures must be taken)
    PPAPP.Visible = True

    ' Create a presentation
    Set PPPres = PPAPP.Presentations.Add

    ' Some PowerPoint actions work best in normal slide view
    PPAPP.ActiveWindow.ViewType = ppViewSlide




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


    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:M16")
        Set chartRng(2) = XLwbk.Sheets("Test2").Range("A1:P23")
        Set chartRng(3) = XLwbk.Sheets("Test3").Range("A1:O20")
        Set chartRng(4) = XLwbk.Sheets("Test4").Range("A1:O22")
        Set chartRng(5) = XLwbk.Sheets("Test5").Range("A1:Q23")
        Set chartRng(6) = XLwbk.Sheets("Test6").Range("A1:O27")
        Set chartRng(7) = XLwbk.Sheets("Test7").Range("A1:K14")
        Set chartRng(8) = XLwbk.Sheets("Test8").Range("A1:O17")



    'Loop through all chart ranges
    'CHANGE WHEN ADDING CHARTS

    For chartNum = 1 To 8
        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

        ' Add a new slide and paste in the chart
        SlideCount = PPPres.Slides.Count

        Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
            PPAPP.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
        With PPSlide
            ' paste and select the chart picture
            .Shapes.Paste.Select
            ' align the chart
            PPAPP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
            PPAPP.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
        End With



                ' 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

Answer 1

我认为你无法一次性粘贴和选择，请尝试以下内容：

With PPSlide
    ' paste and select the chart picture
    .Shapes.Paste
    .Shapes(.Shapes.Count).Select
    ' align the chart
    PPAPP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPAPP.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
End With

Excel宏错误：对象必需

1 个答案: