有没有办法保留这些图表在PowerPoint中的显示顺序?

时间:2019-07-08 18:06:11

标签: excel vba powerpoint

我要解决的问题是将Excel中的复制和粘贴自动化到powerPoint,这目前很耗时,因为我们处理不同工作表中的许多图表。因此,我在网上进行了一些研究,看看是否有人尝试或成功完成了这项任务,这就是研究的成果。但是,它不能完全满足我的目的,因为即使它成功复制并粘贴到了powerpoint中,但由于将其从最早的粘贴到最新的,因此顺序还是很混乱。

我尝试过使用一个循环,该循环从最后一张纸开始到第一张纸,但是每张纸上有多个图表仍然弄乱了我希望看到的图表的显示顺序。

Sub chart_deliveryReverse()

    'declaring all of the objects that will be used
    Dim objPP, objPPFile, mySlide, myShape As Object
    Dim DestinationPPT, button As String
    Dim sht As Worksheet
    Dim charts As Long
    Dim counter, counter1 As Integer
    Dim Xchart As Excel.ChartObject

    'Message Box with a message giving the user Feedback
    button1 = MsgBox("Creating PowerPoint")

    'assign the objPP to powerPoint App
    Set objPP = CreateObject("PowerPoint.Application")
    'make it visible in the screen
    objPP.Visible = True

    'open specific powerPoint presentation
    DestinationPPT = "location of powerPoint"
    Set objPPFile = objPP.Presentations.Open(DestinationPPT)

    'Loop that start from beginning to ended
    For counter = 1 To Worksheets.Count Step 1

    'Commnented loop that starts at the last sheet to the beginning
    'For counter = Worksheets.Count To 1 Step -1

        Set sht = Worksheets(counter)

        'Locate Excel charts to paste into the new PowerPoint presentation
        For Each Xchart In sht.ChartObjects

                'Copy each Excel chart and paste it into PowerPoint
                sht.Activate
                Xchart.Select
                ActiveChart.ChartArea.Copy

                'Customizes the powerPoint first number being where to start inserting slides and second number the layout
                Set mySlide = objPPFile.Slides.Add(2, 11) '11 = ppLayoutTitle
                Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

                mySlide.Shapes.PasteSpecial DataType:=6
                objPP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
                objPP.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

                mySlide.Shapes(1).TextFrame.TextRange.Text = Xchart.Chart.ChartTitle.Text

                'Align the lastest stored shape
                myShape.Left = 100
                myShape.Top = 50
                Next
            Next
    'Next

    ' Clean up
    Set objPP = Nothing
    Set objPPFile = Nothing
    Set mySlide = Nothing

End Sub

它打开指定的PowerPoint,并用Excel工作表中的图表填充它。

0 个答案:

没有答案