[英]Generate a PowerPoint Automated via VBA from Excel Data, Charts, Comments
我想要實現的是通過VBA在Excel中使用數據,圖表,注釋創建自動PowerPointPres。
我有兩件事不能做:
有人可以幫忙一些更正嗎?
真的很感激!
Sub CreatePowerPoint()
'Add a reference to the Microsoft PowerPoint Library by:
'1. Go to Tools in the VBA menu
'2. Click on Reference
'3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each cht In ActiveSheet.ChartObjects
'Add a new slide where we will paste the chart
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
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 PowerPoint as a Metafile Picture
cht.Select
ActiveChart.ChartArea.Copy
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'Set the title of the slide the same as the title of the chart
activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
'Adjust the positioning of the Chart on Powerpoint Slide
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125
activeSlide.Shapes(2).Width = 200
activeSlide.Shapes(2).Left = 505
'If the chart is the "US" consumption chart, then enter the appropriate comments
If InStr(activeSlide.Shapes(1).TextFrame.TextRange.Text, "US") Then
activeSlide.Shapes(2).TextFrame.TextRange.Text = Range("J7").Value & vbNewLine
activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J8").Value & vbNewLine)
'Else if the chart is the "Renewable" consumption chart, then enter the appropriate comments
ElseIf InStr(activeSlide.Shapes(1).TextFrame.TextRange.Text, "Renewable") Then
activeSlide.Shapes(2).TextFrame.TextRange.Text = Range("J27").Value & vbNewLine
activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J28").Value & vbNewLine)
activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J29").Value & vbNewLine)
End If
'Now let's change the font size of the callouts box
activeSlide.Shapes(2).TextFrame.TextRange.Font.Size = 16
Next
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
我想您可以通過將幻燈片創建部分移出循環並將其第一部分更改為如下形式來實現:
'Add a new slide where we will paste the chart
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each cht In ActiveSheet.ChartObjects
Dim i As Integer
i = i + 1
'Copy the chart and paste it
cht.Select
ActiveChart.ChartArea.Copy
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteDefault).Select
'Set the title of the slide the same as the title of the chart
If cht.Chart.HasTitle = True Then
activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
End If
'Adjust the positioning of the Chart on Powerpoint Slide
If i = 1 Then
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 5
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 100
ElseIf i = 2 Then
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 350
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 100
ElseIf i = 3 Then
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 5
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 325
Else
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 350
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 325
End If
然后,您可能必須進行一些調整。
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.