excel - 如何在同一张幻灯片上同时获取数据表和图表

Question

我在 Excel VBA 中有一个代码，可以将我的图表和数据表都导出到 PowerPoint，但我似乎无法将它们都放在同一张幻灯片上（所以 PowerPoint 中的数据表上方的图表）。请帮忙。

Sub ExportMultipleChartsToPowerPoint_FullWorkbook3()   
    'Declare PowerPoint Object Variables
    Dim PPTApp As PowerPoint.Application
    Dim PPTPres As PowerPoint.Presentation
    Dim PPTSlide As PowerPoint.Slide
    Dim PPTShape As PowerPoint.Shape
    Dim PPTShapeRng As PowerPoint.ShapeRange
    Dim ShpCnt As Integer

    'Declare Excel Object Variables
    Dim Chrt As ChartObject
    Dim Wrksht As Worksheet
    Dim SldIndex As Integer
    Dim ExcRng As Range
    Dim RngArray As Variant

    'Create a new instance of PowerPoint
    Set PPTApp = New PowerPoint.Application
    PPTApp.Visible = True

    'Create a new Presentation within the Application
    Set PPTPres = PPTApp.Presentations.Add

    'Create an Index Handler for slide creation
    SldIndex = 1

    'For Errors
    On Error Resume Next

    'Look through all of the Worksheets in the ACTIVE WORKBOOK
    For Each Wrksht In Worksheets
        'Loop through all the Chart Objects on the ACTIVESHEET
        For Each Chrt In Wrksht.ChartObjects      
            'Copy the chart
            Chrt.Copy

            'Tell Macro to wait for ONE SECOND
            Application.Wait Now + #12:00:01 AM#

            'Create a new slide, set the layout to blank, and paste the chart
            Set PPTSlide = PPTPres.Slides.Add(SldIndex, ppLayoutTitleOnly)
            PPTSlide.Shapes.PasteSpecial DataType:=ppPasteJPG

            'Add Text to Slide Title and format
            PPTSlide.Shapes(1).TextFrame.TextRange = "X008 - CARS all bookings consultant YR details"

            'Count the number of shapes on my slide
            ShpCnt = PPTSlide.Shapes.Count

            'Set a reference to the shape I want to manipulate
            Set PPTShapeRng = PPTSlide.Shapes.Range(Array(ShpCnt))

            'Set Dimension of my shape range
            With PPTShapeRng
                .Height = 240
                .Width = 660
                .Top = 135
                .Align msoAlignCenters, True
            End With

            'Increment our slide index
            SldIndex = SldIndex + 1
        Next Chrt
    Next Wrksht

    'Create an array that has the references to the ranges I want to export
    RngArray = Array(Worksheets("Global Results").Range("A30:H37"), Worksheets("G-FPO-GC").Range("A30:H37"), Worksheets("G-FPO-GCA").Range("A30:H37"), Worksheets("G-FPO-GCE").Range("A30:H37"), Worksheets("G-FPO-GCG").Range("A30:H37"), Worksheets("G-FPO-GCN").Range("A30:H37"), Worksheets("G-FPO-GCO").Range("A30:H37"))

    'Loop through this array, copy the range, and create a new slide, and then paste the range in the slide
    For x = LBound(RngArray) To UBound(RngArray)
        'Set a reference to the range we want to export
        Set ExcRng = RngArray(x)

        'Copy the range
        ExcRng.Copy

        'Create a new slide in the presentation
        Set PPTSlide = PPTPres.Slides.Add(x + 1, ppLayoutTitleOnly)

        'Paste the range in the slide
        PPTApp.ActiveWindow.ViewType = ppViewNormal
        PPTSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

        'Count the number of shapes on my slide
        ShpCnt = PPTSlide.Shapes.Count

        'Set a reference to the shape I want to manipulate
        Set PPTShapeRng = PPTSlide.Shapes.Range(Array(ShpCnt))

        'Set the dimensions of my shaperange
        With PPTShapeRng
            .Align msoAlignCenters, True
            .Left = 80
            .Top = 430
            .Height = 100
        End With
    Next x
End Sub

时不时会出现另一条错误消息，说我的 Chrt.Copy 有问题，我不知道为什么

标签： excelvbapowerpoint