將 Excel 儀表板導出到 PowerPoint

Question

我正在嘗試根據 Excel 文件和用戶輸入創建 PPT 生成器。 到目前為止，我設法創建了用戶表單，用戶可以在其中定義他希望在演示文稿中看到的 Excel（圖表加表格）報告。 為了定義選擇了哪個報告，我使用了全局變量。 現在，當我嘗試生成演示文稿時，出現錯誤：“運行時錯誤‘-2147023170(800706b3)’：自動化錯誤。遠程過程調用失敗。” 調試顯示行newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly因為我使用函數 For 來檢查是否選擇了報告（基於我的全局變量） newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly所以我有很多這樣的行如果是，則為每個報告重復代碼。 下面是代碼本身。 我不確定我做錯了什么。

Sub CreatePowerPoint()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'declare the variables
    Dim newPowerPoint As PowerPoint.Application
    Dim activeSlide As PowerPoint.Slide
    Dim cht As Excel.ChartObject
    Dim This As Workbook
    Set This = ActiveWorkbook

 'look for existing instance
    On Error Resume Next
    Set newPowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

 'create a new PowerPoint
    If newPowerPoint Is Nothing Then
        Set newPowerPoint = New PowerPoint.Application
    End If
        newPowerPoint.Presentations.Add
        newPowerPoint.Visible = True

 'TBA Starting Slides/Agenda
       *Code here*


'Check if report was selected, if yes perform addition of new slides with graphs and tables

If CB1 = 1 Then
This.Worksheets("Coverage Summary").Select
    For Each cht In ActiveSheet.ChartObjects

    'Add a new slide
        newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly
        newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

    'Copy the chart and paste it into the PP
        cht.Select
        ActiveChart.ChartArea.Copy
        activeSlide.Shapes.PasteSpecial(DataType:=ppPasteChartObject).Select

    'Set the title of the slide
        activeSlide.Shapes(1).TextFrame.TextRange.Text = "Coverage Summary" 

    'Adjust the positioning
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125

    Next
Set activeSlide = Nothing
End If

If CB2 = 1 Then
This.Worksheets("Additions Report").Select
    For Each cht In ActiveSheet.ChartObjects

    'Add a new slide
        newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly
        newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

    'Copy the chart and paste it into the PP
        cht.Select
        ActiveChart.ChartArea.Copy
        activeSlide.Shapes.PasteSpecial(DataType:=ppPasteChartObject).Select

    'Set the title of the slide
        activeSlide.Shapes(1).TextFrame.TextRange.Text = "Additions summary" 

    'Adjust the positioning
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125

    Next
Set activeSlide = Nothing
End If

If CB3 = 1 Then
This.Worksheets("End of Coverage Report").Select
*Same code as above*
Set activeSlide = Nothing
End If

If CB4 = 1 Then
This.Worksheets("LDoS Summary").Select
*Same code as above*
End If

If CB5 ... * and so on

我在這里沒有想法了。 我不知道如何更正代碼。 有人可以幫忙嗎？

Answer 1

我的建議是，當您從 Excel vba 以編程方式創建 PowerPoint 並使用 ActiveSheet 等時，不要“選擇”對象； 直接將對象設置為要使用的工作表。 也就是說，雖然沒有完全清理你的代碼......這有效（僅適用於 CB1......但其余的應該是相似的）：

代碼更新

Option Explicit

Sub CreatePowerPoint()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    'declare the variables
    Dim newPowerPoint As PowerPoint.Application
    Dim newPresentation As Presentation
    Dim activeSlide As PowerPoint.Slide
    Dim cht As Excel.ChartObject
    Dim This As Workbook
    Set This = ActiveWorkbook
    
    Dim newWorksheet As Worksheet
    
     'look for existing instance
    On Error Resume Next
    Set newPowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
    
     'create a new PowerPoint
    If newPowerPoint Is Nothing Then
        Set newPowerPoint = New PowerPoint.Application
    End If
    Set newPresentation = newPowerPoint.Presentations.Add
    newPowerPoint.Visible = True
    
     'TBA Starting Slides/Agenda
     '  *Code here*
    
    'Check if report was selected, if yes perform addition of new slides with graphs and tables
    
    'If CB1 = 1 Then
    If 1 = 1 Then
        Set newWorksheet = This.Worksheets("Coverage Summary")
        For Each cht In newWorksheet.ChartObjects
    
            'Add a new slide and setup the slide title
            Set activeSlide = newPresentation.Slides.Add(newPresentation.Slides.Count + 1, ppLayoutTitleOnly)
            activeSlide.Shapes(1).TextFrame.TextRange.Text = "Coverage Summary"
            
            ' Copy in the chart and adjust its position
            cht.Copy
            activeSlide.Shapes.PasteSpecial DataType:=ppPasteDefault
            With activeSlide.Shapes(activeSlide.Shapes.Count)
                .Top = 125
                .Left = 15
                ' and could you also set .Width and .Height here as well ...
            End With

        Next
    End If
    
    'If CB2 = 1 Then
    If 1 = 1 Then
        Set newWorksheet = This.Worksheets("Additions Report")
        For Each cht In newWorksheet.ChartObjects
    
            'Add a new slide and setup the slide title
            Set activeSlide = newPresentation.Slides.Add(newPresentation.Slides.Count + 1, ppLayoutTitleOnly)
            activeSlide.Shapes(1).TextFrame.TextRange.Text = "Additions Report"
            
            ' Copy in the chart and adjust its position
            cht.Copy
            activeSlide.Shapes.PasteSpecial DataType:=ppPasteDefault
            With activeSlide.Shapes(activeSlide.Shapes.Count)
                .Top = 125
                .Left = 15
                ' and could you also set .Width and .Height here as well ...
            End With

        Next
    End If
    
End Sub

這是測試數據集的圖片

這是輸出 PowerPoint 的圖片：