I want VBA to paste all the Worksheets into example PPT, which started from particular slide, for example slide NUM.3
However the code which is in use right now, do not paste the selected area into PPT file. Could you help me?
Here is my code:
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
Set rng = ThisWorkbook.ActiveSheet.Range("A1:Z100")
' Set mySlide = myPresentation.Slides.Add(myPresentation.Slides.Count + 1, 12)
' SlideNumb = myPresentation.Slides.Count
Set mySlide = myPresentation.Slides(SlideNumb).Select '(myPresentation.Slides.Count + 1, 12) '(myPresentation.Slides.Count + 1, 12)
rng.Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.LockAspectRatio = msoFalse
myShape.Left = 36.72
myShape.Top = 112.32
myShape.Width = 854.64
myShape.Height = 397.44
Application.CutCopyMode = False
ShtNum = ShtNum + 1
SlideNumb = SlideNumb + 1
Next ws
Change this:
Set mySlide = myPresentation.Slides(SlideNumb).Select
To this:
Set mySlide = myPresentation.Slides(SlideNumb)
Delete this:
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.LockAspectRatio = msoFalse
myShape.Left = 36.72
myShape.Top = 112.32
myShape.Width = 854.64
myShape.Height = 397.44
remove the comments and give it a try again.
Related
I have an Excel with Macro which should:
toggle to active PPT
select slide "X" and delete graphs
Go to Tab "X" in excel
grab new Graph
Paste onto the "X" slide
repeat 5 times
here is the code I've compiled so far:
Dim PPT As Object
Dim rng As Object
Dim rng1 As Object
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim ActivePresentation As Object
'Copy Range from Excel
Set rng = Sheet3.ChartObjects("Chart 6")
Set rng1 = Sheet3.ChartObjects("Chart 7")
Set rng2 = Sheet3.ChartObjects("Chart 8")
Set PPT = CreateObject("PowerPoint.Application")
With PPT
.Visible = True
.WindowState = 1
.Activate
End With
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Set myPresentation = PowerPointApp.Presentations.Add *this should not say add as it adds a slide,but no luck with any other commands*
' PowerPointApp.Presentations.Add
Set mySlide = myPresentation.Slides.Add(1, 11) *this should not say add as it adds a slide,but no luck with any other commands*
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 20
myShape.Top = 152
rng1.Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.Left = 486
myShape.Top = 152
Set mySlide = myPresentation.Slides.Add(2, 11) '11 = ppLayoutTitleOnly
etc..
End Sub
this creates a new PPT and add slides to the new ppt, have tried a numerous helps and web pages but unfortunately was not able to find a piece of code which would tackle this problem. Would be much appreciated if you could advise or point me to the correct help or tutorial which would be possible to solve this issue with.
code is based on the following assumptions from your statement
Already have a presentation open
want to copy two or three charts from each sheets, starting from Sheets(2) to Sheets(5) to slides 2 to 5 respectively as shown below.
Code may be modified to your requirement
Sub AddtoOpenPPT()
Dim PPT As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShape As PowerPoint.Shape
Dim Fname As String
Dim sld As Long, i As Long, ObjNo As Long
Dim Rng(0 To 9) As Object
Set Rng(0) = Sheet3.ChartObjects("Chart 6")
Set Rng(1) = Sheet3.ChartObjects("Chart 7")
Set Rng(2) = Sheet3.ChartObjects("Chart 8")
Set Rng(3) = Sheet3.ChartObjects("Chart 5")
Set Rng(4) = Sheet1.Range("b4:j14")
Set Rng(5) = Sheet1.Range("A4:l4", "A15:j19")
Set Rng(6) = Sheet4.ChartObjects("Chart 13")
Set Rng(7) = Sheet4.ChartObjects("Chart 15")
Set Rng(8) = Sheet4.ChartObjects("Chart 17")
Set Rng(9) = Sheet4.ChartObjects("Chart 19")
Set PPT = GetObject(class:="PowerPoint.Application")
Set myPresentation = PPT.ActivePresentation
ObjNo = 0
For sld = 2 To 5
Set mySlide = myPresentation.Slides(sld)
For i = mySlide.Shapes.Count To 1 Step -1
mySlide.Shapes(i).Delete
Next
For i = 1 To 3
Rng(ObjNo).Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.Left = IIf(i Mod 2 = 1, 20, 486)
myShape.Top = IIf(i < 3, 50, 200)
ObjNo = ObjNo + 1
If ObjNo > UBound(Rng) Then Exit For
Next
If ObjNo > UBound(Rng) Then Exit For
Next sld
End Sub
I want to loop though only a specific set of charts in one sheet and then apply to those a set of formating (title font size, title position, axis size, grid lines formating etc.)
The problem ist that there are already 66 charts on that sheet that were manually created (1 to 66). I will now add more charts but automatically generated, and only for those ones I would like to apply the formating needed.
For now I managed to create the charts and apply the formating separately. But in order to make it more fluid I would require a loop that I have not figured out yet. My idea was/is to count all Charts on the sheet and then do something like "If cnt > 66 Then "put here the code starting from the cht.Activate line".
My problem is counting all the charts. I am guessing using something like
with For -> For i to .CharObjects(i). But maybe you can suggest a different way.
Public Sub TEST()
Dim rng As Range, rng1 As Range, rng2 As Range, rng3 As Range
Dim cht As ChartObject, cht1 As ChartObject, cht2 As ChartObject, cht3 As ChartObject
Dim LastRow As Long
Dim wsG As Worksheet: Set wsG = ThisWorkbook.Worksheets("Charts")
Dim wsS As Worksheet: Set wsS = ThisWorkbook.Worksheets("Scatter Raw")
LastRow = wsS.Cells(wsS.Rows.count, "A").End(xlUp).Row
Set rng1 = wsS.Range("A4:B" & LastRow)
Set rng2 = wsS.Range("H4:I" & LastRow)
Set rng3 = wsS.Range("O4:P" & LastRow)
Set cht1 = wsG.ChartObjects.Add(Range("A595").Left, Range("A595").Top, Width:=518.5, Height:=296.7)
Set cht2 = wsG.ChartObjects.Add(Range("M595").Left, Range("M595").Top, Width:=518.5, Height:=296.7)
Set cht3 = wsG.ChartObjects.Add(Range("Y595").Left, Range("Y595").Top, Width:=518.5, Height:=296.7)
cht1.Chart.SetSourceData Source:=rng1
cht1.Chart.ChartType = xlXYScatter
cht1.ShapeRange.LockAspectRatio = msoTrue
cht1.Activate
With ActiveChart
.FullSeriesCollection(1).Name = "=""NAME 1"""
.ChartTitle.Text = "TITLE 1"
End With
cht2.Chart.SetSourceData Source:=rng2
cht2.Chart.ChartType = xlXYScatter
cht2.ShapeRange.LockAspectRatio = msoTrue
cht2.Activate
With ActiveChart
.FullSeriesCollection(1).Name = "=""NAME 2"""
.ChartTitle.Text = "TITLE 2"
End With
cht3.Chart.SetSourceData Source:=rng3
cht3.Chart.ChartType = xlXYScatter
cht3.ShapeRange.LockAspectRatio = msoTrue
cht3.Activate
With ActiveChart
.FullSeriesCollection(1).Name = "=""NAME 3"""
.ChartTitle.Text = "TITLE 3"
End With
For Each cht In wsG.ChartObjects
cht.Activate
With ActiveChart
.Legend.Delete
.ChartTitle.Font.Size = 14
.ChartTitle.Select
With Selection.Format.TextFrame2.TextRange.Font.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.150000006
.Transparency = 0
.Solid
End With
Selection.Left = 27.536
Selection.Top = 5
.ChartArea.Select
With Selection.Format.Line
.Visible = msoFalse
End With
With .Axes(xlValue).TickLabels.Font
.Size = 11
End With
.Axes(xlValue).Select
Selection.Format.Line.Visible = msoFalse
.Axes(xlValue).MajorGridlines.Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = -0.25
.Transparency = 0
.Visible = msoTrue
.DashStyle = msoLineDash
End With
End With
Next cht
End Sub
If you want to ignore Chart 3 and Chart 2, add these two names to an array. Then check whether the chart object has name from this array and act accordingly:
Public Sub TestMe()
Dim myChart As ChartObject
Dim chartCount As Long
Dim cnt As Long
Dim chartNamesToExclude As Variant
chartNamesToExclude = Array("Chart 3", "Chart 2")
For Each myChart In Worksheets(1).ChartObjects
If Not valueInArray(myChart.Name, chartNamesToExclude) Then
cnt = cnt + 1
myChart.Chart.ChartTitle.Text = "Title" & cnt
End If
Next myChart
End Sub
Public Function valueInArray(myValue As Variant, myArray As Variant) As Boolean
Dim cnt As Long
For cnt = LBound(myArray) To UBound(myArray)
If CStr(myValue) = CStr(myArray(cnt)) Then
valueInArray = True
Exit Function
End If
Next cnt
End Function
The code above loops through all the charts in Worksheets(1) and changes their titles accordingly to Title N. It ignores the charts with names Chart 3 and Chart 2, by seeing that these are in chartNamesToExclude array.
Thanks Vityata. You solution worked but I think I have found what I was looking for in the beginning. I am not sure if it is better, but it does the job also. Here it is. Cheers, Daniel
Private Sub newtest()
Dim rng As Range, rng1 As Range, rng2 As Range, rng3 As Range
Dim cht As ChartObject, cht1 As ChartObject, cht2 As ChartObject, cht3 As ChartObject
Dim LastRow As Long
Dim wsG As Worksheet: Set wsG = ThisWorkbook.Worksheets("Charts Radio")
Dim wsS As Worksheet: Set wsS = ThisWorkbook.Worksheets("Scatter Raw")
Dim i As Long
For i = 67 To wsG.ChartObjects.count
wsG.ChartObjects(i).Activate
With ActiveChart
.Legend.Delete
.ChartTitle.Font.Size = 14
.ChartTitle.Select
With Selection.Format.TextFrame2.TextRange.Font.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.150000006
.Transparency = 0
.Solid
End With
Selection.Left = 27.536
Selection.Top = 5
'Added more formating / code here
End With
Next
End Sub
My code generates 4 PowerPoint files from an excel document where I've aggregated data from my main file. One by one, it cuts and pastes a section of the excel sheet onto an individual slide, replaces some filler words with the appropriate date, saves and closes.
My code works, however it SOMETIMES gets tripped up with a
Run-time error -2147188160 (80048240)
a pasting error, which doesn't always happen in the same place. The remedy is always to exit my program and re-run it. The code executes in less than 10 seconds, so this is no big deal, just fair nuisance. Sometimes it takes 1 or 2 tries to get it to work.
Any advice on how to avoid these annoying run-time error trip ups?
Sub GeneratePowerPoints()
'For using powerpoint
Dim dummyfile As String
Dim PPT As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim MySlide As Object
Dim MyShape As Object
'Dim myPresentation As PowerPoint.Presentation
Dim j As Long, allhotels() As Variant, sourcerange As Range, sourcebook As String
Dim d As Date, e As Date, f As Date, lastmonth As String, twomonthsago As String, threemonthsago As String
'Get some month names
d = DateAdd("m", -1, Now)
e = DateAdd("m", -2, Now)
f = DateAdd("m", -3, Now)
lastmonth = Format(d, "mmmm")
twomonthsago = Format(e, "mmmm")
threemonthsago = Format(f, "mmmm")
sourcebook = "BT Strat Sheet.xlsm"
allhotels = Array("SBH", "WBOS", "WBW", "WCP")
dummyfile = "P:\BT\BT 2017\BT Strategy Meetings\2017\Hotel Strat Meeting Dummy File.pptx"
For j = 0 To 3
Set PPT = New PowerPoint.Application
PPT.Visible = True
PPT.Presentations.Open Filename:=dummyfile
'SLIDE ONE
Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A2:J21")
sourcerange.Copy
PPT.ActivePresentation.Slides(1).Shapes.PasteSpecial DataType:=2
Set MyShape = PPT.ActivePresentation.Slides(1).Shapes(PPT.ActivePresentation.Slides(1).Shapes.Count)
'Set size
MyShape.Left = 152
MyShape.Top = 152
MyShape.Height = 500
MyShape.Width = 650
'SLIDE TWO
Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A73:J82")
sourcerange.Copy
PPT.ActivePresentation.Slides(2).Shapes.PasteSpecial DataType:=2
Set MyShape = PPT.ActivePresentation.Slides(2).Shapes(PPT.ActivePresentation.Slides(2).Shapes.Count)
'Set size
MyShape.Left = 152
MyShape.Top = 92
MyShape.Height = 500
MyShape.Width = 650
'SLIDE TWO
Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A85:J94")
sourcerange.Copy
PPT.ActivePresentation.Slides(2).Shapes.PasteSpecial DataType:=2
Set MyShape = PPT.ActivePresentation.Slides(2).Shapes(PPT.ActivePresentation.Slides(2).Shapes.Count)
'Set size
MyShape.Left = 152
MyShape.Top = 300
MyShape.Height = 500
MyShape.Width = 650
'SLIDE THREE
Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A24:J43")
sourcerange.Copy
PPT.ActivePresentation.Slides(3).Shapes.PasteSpecial DataType:=2
Set MyShape = PPT.ActivePresentation.Slides(3).Shapes(PPT.ActivePresentation.Slides(3).Shapes.Count)
'Set size
MyShape.Left = 152
MyShape.Top = 152
MyShape.Height = 500
MyShape.Width = 650
'SLIDE FOUR
Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A54:J58")
sourcerange.Copy
PPT.ActivePresentation.Slides(4).Shapes.PasteSpecial DataType:=2
Set MyShape = PPT.ActivePresentation.Slides(4).Shapes(PPT.ActivePresentation.Slides(4).Shapes.Count)
'Set size
MyShape.Left = 152
MyShape.Top = 152
MyShape.Height = 500
MyShape.Width = 650
'SLIDE FOUR
Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A46:J50")
sourcerange.Copy
PPT.ActivePresentation.Slides(4).Shapes.PasteSpecial DataType:=2
Set MyShape = PPT.ActivePresentation.Slides(4).Shapes(PPT.ActivePresentation.Slides(4).Shapes.Count)
'Set size
MyShape.Left = 152
MyShape.Top = 380
MyShape.Height = 500
MyShape.Width = 650
'SLIDE FIVE
Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A61:J70")
sourcerange.Copy
PPT.ActivePresentation.Slides(5).Shapes.PasteSpecial DataType:=2
Set MyShape = PPT.ActivePresentation.Slides(5).Shapes(PPT.ActivePresentation.Slides(5).Shapes.Count)
'Set size
MyShape.Left = 152
MyShape.Top = 152
MyShape.Height = 500
MyShape.Width = 650
'Find and replace month placeholders
'Straight boilerplate
Dim sld As Slide, shp As PowerPoint.Shape, i As Long
For Each sld In PPT.ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "LastMonth", lastmonth)
End If
End If
Next shp
Next sld
For Each sld In PPT.ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "TwoMonthsAgo", twomonthsago)
End If
End If
Next shp
Next sld
For Each sld In PPT.ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "ThreeMonthsAgo", threemonthsago)
End If
End If
Next shp
Next sld
'Save it
PPT.ActivePresentation.SaveAs "P:\BT\BT File Drop-off Location\" & allhotels(j) & " " & lastmonth & " Strat Meeting.pptx"
'Close it
PPT.ActivePresentation.Close
Next j
'Exit PowerPoint
PPT.Quit
End Sub
I have some VBA code that successfully copies a range from Excel into slide two of a new presentation based on a template (the VBA opens Powerpoint).
The macro ends by pasting the chart into slide two from a worksheet in Excel. What I want to do now is go back to that worksheet, copy the chart that has already been plotted from that data and paste it into the same slide that the data has just been pasted into.
My Code
'Plots Chart Based on Tabular Data
Range("A1:B1").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Shapes.AddChart2(201, xlColumnClustered).Select
ActiveChart.ApplyChartTemplate ( _
"C:\Users\Colin\AppData\Roaming\Microsoft\Templates\Charts\Edge45 Bar Chart Transparent Horizontal Bars.crtx")
ActiveChart.SetSourceData Source:=Range("'Screaming Frog Summary'!$A$1:$B$16")
ActiveSheet.Shapes("Chart 1").IncrementLeft -57.6
ActiveSheet.Shapes("Chart 1").IncrementTop 243.9
'Opens a new PowerPoint presentation based on template and pastes data into Slide 2 of Powerpoint from Excel
Dim PPApp As PowerPoint.Application, PPPres As PowerPoint.Presentation, PPSlide As PowerPoint.Slide, PPShape As Object
Dim XLws As Worksheet
Set XLws = ActiveSheet
Set PPApp = New PowerPoint.Application
Set PPPres = PPApp.Presentations.Open("C:\Users\Colin\Dropbox (Edge45)\Edge45 Team Folder\Edge45 Company Documents\Templates\Powerpoint Templates\Edge45 Audit Template Macro.potm", Untitled:=msoTrue)
PPApp.Visible = True
Set PPSlide = PPPres.Slides(2)
XLws.Range("A1:D16").Copy
Set PPShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteHTML, Link:=msoFalse)
Application.CutCopyMode = False
With PPShape
.Top = 10
.Height = 100
.Left = 10
.Width = 100
End With
I don't know how many charts you have on the source sheet but assuming it's just one, if you add these lines at the end of your code it will copy and paste the first chart from your referenced sheet to your second slide:
XLws.ChartObjects(1).Copy ' or XLws.ChartObjects("Chart 1").Copy
Set PPChart = PPSlide.Shapes.PasteSpecial (ppPasteDefault)
Note that if the target slide has empty chart and/or object placeholders, the chart can be automatically pasted into a target placeholder if you select it first with something like this:
PPSlide.Shapes.Placeholders(2).Select
Index 2 may need to be changed depending on your slide's layout.
You can then move the chart like this:
With PPChart
.Top = 10
.Height = 100
.Left = 10
.Width = 100
End With
This is not fully tested (as I don't have Excel 2013), so I can't test AddChart2, but similar code with Charts work with 2010.
Let me know if you are getting an error on the following line:
Set Cht = XLws.Shapes.AddChart2(201, xlColumnClustered).Chart
Code
Option Explicit
Sub ExportToPPT()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PPShape As Object, PPChart As Object
Dim XLws As Worksheet
Dim Cht As Chart
Set XLws = ActiveSheet
'Plots Chart Based on Tabular Data
XLws.Range(Range("A1:B1"), Range("A1:B1").End(xlDown)).Select
Set Cht = XLws.Shapes.AddChart2(201, xlColumnClustered).Chart
With Cht
.ApplyChartTemplate ("C:\Users\Colin\AppData\Roaming\Microsoft\Templates\Charts\Edge45 Bar Chart Transparent Horizontal Bars.crtx")
.SetSourceData Source:=Range("'Screaming Frog Summary'!$A$1:$B$16")
.Shapes("Chart 1").IncrementLeft -57.6
.Shapes("Chart 1").IncrementTop 243.9
End With
'Opens a new PowerPoint presentation based on template and pastes data into Slide 2 of Powerpoint from Excel
Set PPApp = New PowerPoint.Application
Set PPPres = PPApp.Presentations.Open("C:\Users\Colin\Dropbox (Edge45)\Edge45 Team Folder\Edge45 Company Documents\Templates\Powerpoint Templates\Edge45 Audit Template Macro.potm", Untitled:=msoTrue)
PPApp.Visible = True
Set PPSlide = PPPres.Slides(2)
XLws.Range("A1:D16").Copy
Set PPShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteHTML, Link:=msoFalse)
Application.CutCopyMode = False
With PPShape
.Top = 10
.Height = 100
.Left = 10
.Width = 100
End With
Cht.ChartArea.Copy '<-- copy the Chart
Set PPChart = PPSlide.Shapes.PasteSpecial(ppPasteDefault, msoFalse) 'ppPasteShape
End Sub
You can use different type of PasteSpecial, just choose the one you prefer :
I've set 2 ways to place the pasted shapes, so that you can set it easily!
Sub test_Superhans()
Dim PPApp As PowerPoint.Application, PPPres As PowerPoint.Presentation, PPSlide As PowerPoint.Slide, PPShape As Object
Dim wS As Excel.Worksheet, Rg As Excel.Range, oCh As Object
'Opens a new PowerPoint presentation based on template
Set PPApp = New PowerPoint.Application
PPApp.Visible = True
Set PPPres = PPApp.Presentations.Open( _
"C:\Users\Colin\Dropbox (Edge45)\Edge45 Team Folder\Edge45 Company Documents\Templates\Powerpoint Templates\Edge45 Audit Template Macro.potm", _
Untitled:=msoTrue)
Set PPSlide = PPPres.Slides(2)
'Set the sheet where the data is
Set wS = ThisWorkbook.Sheets("Screaming Frog Summary")
With wS
Set Rg = .Range("A1:B" & .Range("A" & .Rows.Count).End(xlUp).Row)
Set oCh = .Shapes.AddChart2(201, xlColumnClustered)
End With 'wS
With oCh
.ApplyChartTemplate ( _
"C:\Users\Colin\AppData\Roaming\Microsoft\Templates\Charts\Edge45 Bar Chart Transparent Horizontal Bars.crtx")
.SetSourceData Source:=Rg
.Copy
End With 'oCh
'Paste and place the chart
''Possibles DataType : see the image! ;)
Set PPShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile, Link:=msoFalse)
Application.CutCopyMode = False
With PPShape
.Height = 100
'Place from bottom using : PPPres.PageSetup.SlideHeigth - .Height
.Top = PPPres.PageSetup.SlideHeigth - .Height - 10
.Width = 100
'Place from right using : PPPres.PageSetup.SlideWidth - .Width
.Left = PPPres.PageSetup.SlideWidth - .Width - 10
End With
'Copy the data
Rg.Copy
Set PPShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteHTML, Link:=msoFalse)
Application.CutCopyMode = False
With PPShape
.Height = 100
'Place from top
.Top = 10
.Width = 100
'Place from left
.Left = 10
End With
End Sub
I'm trying to copy charts from Excel to an existing Powerpoint Template using VBA. This code returns Error 438 - Object doesn't support this property or method:
'Create a new Powerpoint session
Set pptApp = CreateObject("PowerPoint.Application")
'
pptApp.Visible = msoTrue
'Create a new presentation
Set pptPres = pptApp.Presentations.Open("....potx")
Set pptPres = pptApp.ActivePresentation
'
pptApp.ActiveWindow.ViewType = ppViewSlide
'
Current_slide = pptPres.Slides.FindBySlideID(258)
For Each ws In ActiveWorkbook.Worksheets
'Verify if there is a chart object to transfer
If ws.ChartObjects.Count > 0 Then
For Each objChartObject In ws.ChartObjects
Set objChart = objChartObject.Chart
'ppLayoutBlank = 12
Set pptSld = pptPres.Slides.FindBySlideID(Current_slide)
pptApp.ActiveWindow.View.GotoSlide (pptSld)
With objChart
'Copy chart object as picture
objChart.CopyPicture xlScreen, xlBitmap, xlScreen
'Paste copied chart picture into new slide
pptSld.Shapes.Paste.Select
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
End With
Current_slide = Current_slide + 1
Next objChartObject
End If
Next ws
Add this at top of module:
Option Explicit
Then try it with these changes (aircode, mostly, but it's a start):
Dim Current_slide as Long
Dim pptSlide as PowerPoint.Slide
Dim oShRange as PowerPoint.ShapeRange
' I don't know why exactly you're using FindBySildeID
' Care to explain that?
Current_slide = pptPres.Slides.FindBySlideID(258).SlideIndex
For Each ws In ActiveWorkbook.Worksheets
'Verify if there is a chart object to transfer
' Don't really need this; if count is 0, the code within the
' For Each loop won't execute:
' If ws.ChartObjects.Count > 0 Then
For Each objChartObject In ws.ChartObjects
Set objChart = objChartObject.Chart
'ppLayoutBlank = 12
' This needs a LONG not an object, so
Set pptSld = pptPres.Slides.FindBySlideID(Current_slide)
' You don't really need to GoTo the slide in order to operate on it
' Doing so will slow things down; if you want to see it work, though,
' uncomment:
' pptApp.ActiveWindow.View.GotoSlide (pptSld)
With objChart
'Copy chart object as picture
objChart.CopyPicture xlScreen, xlBitmap, xlScreen
'Paste copied chart picture into new slide
' pptSld.Shapes.Paste.Select
Set oShRange = pptSld.Shapes.Paste
With oShRange
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
End With ' oShRange
End With
Current_slide = Current_slide + 1
Next objChartObject
' End If
Next ws