我要解决的问题是将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工作表中的图表填充它。