[英]Creating a powerpoint with multiple charts on each slide from excel using vba
I currently have a working code that takes each chart from my excel spreadsheet and creates a PowerPoint presentation that puts all of my charts on the same slide. 我目前有一个工作代码,可以从excel电子表格中获取每个图表,并创建一个PowerPoint演示文稿,将我的所有图表放在同一张幻灯片上。 I would like the macro to put four (4) charts on each slide but I am having trouble, any help is appreciated.(note- I haven't adjusted the size of the charts once they are in PowerPoint, I will handle this after I get 4 in each slide) My current code is as seen below
我希望宏在每张幻灯片上放置四(4)张图表,但是我遇到了麻烦,不胜感激。(注意-一旦在PowerPoint中我没有调整图表的大小,我将在以后处理每张幻灯片我得到4个)我当前的代码如下所示
Private Sub CommandButton17_Click()
'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
'keep button in same location
Set btn = ActiveSheet.Shapes("CommandButton17")
With btn
btLeft = .Left
btTop = .Top
End With
'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
' newPowerPoint.ActivePresentation.ApplyTemplate _
' "D:\Documents and Settings\austin.plantz\Desktop\Misc Projects\CSA PP Theme.thmx"
'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For i = 1 To ActiveSheet.ChartObjects.Count
Set cht = ActiveSheet.ChartObjects(i)
' With ActivePresentation.SlideMaster
' .CustomLayouts.Add (1)
' .CustomLayouts(1).Name = "Title And Content"
' End With
'Add a new slide where we will paste the chart
If i - 1 Mod 4 = 0 Then
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutTitle
End If
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 = 165
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 150
newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 400
activeSlide.Shapes(2).Width = 200
activeSlide.Shapes(2).Left = 505
activeSlide.Shapes(1).Top = 25
Next
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
First change you ForEach loop to For 首先将您的ForEach循环更改为
For i = 1 To ActiveSheet.ChartObjects.Count
Set cht = ActiveSheet.ChartObjects(i)
Then put condition before creation of slides: 然后在创建幻灯片之前设置条件:
chartNum = (i - 1) Mod 4
If chartNum = 0 Then
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutTitle
End If
Then, put logic for placing charts on each slide : 然后,在每张幻灯片上放置用于放置图表的逻辑:
If chartNum = 0 Then
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 50
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 50
ElseIf chartNum = 1 Then
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 300
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 50
ElseIf chartNum = 2 Then
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 50
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 300
Else
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 300
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 300
End If
newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 200
newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 200
Of course, play with lefts, tops, heights and widths yourself. 当然,自己玩左,上,高和宽。
dont forget to use this before setting Width or Height of chart: 在设置图表的宽度或高度之前,请不要忘记使用此功能:
sr.LockAspectRatio = msoFalse
Here sr
stands for PPApp.ActiveWindow.Selection.ShapeRange
sr
在这里代表PPApp.ActiveWindow.Selection.ShapeRange
Option Base 1
Sub CreatePowerPoint()
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
Dim left1(8)
Dim top1(8)
left1(1) = 20: top1(1) = 70
left1(2) = 350: top1(2) = 70
left1(3) = 20: top1(3) = 300
left1(4) = 350: top1(4) = 300
left1(5) = 20: top1(5) = 70
left1(6) = 350: top1(6) = 70
left1(7) = 20: top1(7) = 300
left1(8) = 350: top1(8) = 300
n = ActiveSheet.ChartObjects.Count
nn = WorksheetFunction.RoundUp(n / 4, 0)
g = 1
For pp = 1 To nn
p = g
t = p + 3
x = 1
For h = p To t
On Error Resume Next
ActiveSheet.ChartObjects(h).Select
ActiveChart.ChartArea.Copy
newPowerPoint.ActiveWindow.ViewType = ppViewSlide
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
Application.CutCopyMode = False
With activeSlide.Shapes(x)
.Width = 150
.Width = 200
End With
With newPowerPoint.ActiveWindow.Selection.ShapeRange
.Left = left1(x)
.Top = top1(x)
End With
x = x + 1
Next
g = t + 1
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
newPowerPoint.ActiveWindow.ViewType = ppViewSlide
Next
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.