I have the following code. It takes data from excel and pastes it into a PPT template.
As you can see I use ppSlide to keep track of which slide I'm currently on. To do so I set the number of the next slide when I'm done with the slide before.
However, when I run the code it pastes the second file on the 2nd slide (should be the 3rd slide). Any ideas as to why?
Sub maakPPT()
Application.ScreenUpdating = False
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Dim wsReoOverzicht As Worksheet
Dim chPlanning As Chart
Dim grafPersImp As Range
Dim wsGrafiek As Worksheet
Set wsReoOverzicht = Worksheets("Reo's gestart")
Set chPlanning = Charts("Planning")
Set wsGrafiek = Worksheets("Grafiek")
Set grafPersImp = wsGrafiek.Range("A3:N24")
'ppt openen
Set ppApp = New PowerPoint.Application
ppApp.Visible = True
ppApp.Activate
'template openen 2e slide selecteren
Set ppPres = ppApp.Presentations.Open("F:\WGD\Dep 456566-Centrale Reorganisatieteam\AAB CRT Algemeen\PMO CRT\Dashboards\ppt presentaties\Template Totaaloverzicht.pptx")
Set ppSlide = ppPres.Slides(2)
'Totaal lopende Reo's (planning)
wsReoOverzicht.ListObjects("Tabel1").Range.AutoFilter Field:=12, Criteria1:= _
"Lopend"
chPlanning.CopyPicture _
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
ppSlide.Select
ppApp.ActiveWindow.View.Paste
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
ppSlide.Shapes(2).Width = 600
ppSlide.Shapes(2).Height = 375
ppSlide.Shapes.Range(2).Align msoAlignCenters, True
ppSlide.Shapes.Range(2).Align msoAlignMiddles, True
Set ppSlide = ppApp.ActivePresentation.Slides(3)
'Totaal personele impact (grafiek)
grafPersImp.Copy
ppApp.ActiveWindow.View.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
ppSlide.Shapes(2).Width = 400
ppSlide.Shapes(2).Height = 275
ppSlide.Shapes.Range(2).Align msoAlignCenters, True
ppSlide.Shapes.Range(2).Align msoAlignMiddles, True
Set ppSlide = ppApp.ActivePresentation.Slides(4)
The difference with the first painting step was that I didn't use ppSlide.select to make it the active sheet.
Related
I'm using this code for exporting Excel charts to PowerPoint
Sub ChartsToPresentation()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PresentationFileName As Variant
Dim SlideCount As Long
Dim iCht As Integer
Application.CutCopyMode = False
Set PPApp = GetObject(, "Powerpoint.Application.16")
Set PPSlide = PPApp.ActiveWindow.View.Slide
nv = PPApp.ActiveWindow.Selection.SlideRange.SlideIndex
ActiveChart.ChartArea.Select
Selection.Copy
ggg: Set shp = PPApp.ActivePresentation.Slides(nv).Shapes.PasteSpecial(DataType:=0)
If Err Then GoTo ggg
Application.CutCopyMode = False
End Sub
As I'm invoking the sub for many different charts in a loop, I get often an error "Clipboard is empty or contains data which may not be pasted". It looks as delay problem between the Copy and the paste.
I'm using Win10 office 2016 64b
Is there a workaround?
I've tried to do it with VB6 but looks the same problem
Use ppPasteEnhancedMetafile = 2 or ppPasteShape = 11 or ppPasteJPG = 5
as DataType for charts!
Cleaned and improved code :
Sub ChartsToPresentation()
Dim PPApp As PowerPoint.Application
Dim PPSlide As PowerPoint.Slide
Application.CutCopyMode = False
Set PPApp = GetObject(, "Powerpoint.Application")
Set PPSlide = PPApp.ActiveWindow.View.Slide
ActiveChart.ChartArea.Copy
DoEvents
PPSlide.Shapes.PasteSpecial DataType:=ppPasteShape
Application.CutCopyMode = False
End Sub
Or take a pick :
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 am looking to copy + paste selected charts in Excel into an active PPT slide. I have a code that creates a new workbook and pastes all charts that are within the workbook but would like to limit the command to just selected charts. Here's the code:
Option Explicit
Sub CopyChartsToPowerPoint()
'Excel Application objects declaration
Dim ws As Worksheet
Dim objChartObject As ChartObject
Dim objChart As Chart
Dim objCht As Chart
Dim lngSlideKount As Long
'Powerpoint Application objects declaration
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
'Create a new Powerpoint session
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = msoTrue
'Create a new presentation
Set pptPres = pptApp.Presentations.Add
Set pptPres = pptApp.ActivePresentation
pptApp.ActiveWindow.ViewType = ppViewSlide
lngSlideKount = 0
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.Add(lngSlideKount + 1, 12)
pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
With objChart
'Copy + paste chart object as picture
objChart.CopyPicture xlScreen, xlBitmap, xlScreen
pptSld.Shapes.Paste.Select
'Coordinates will change depending on chart
With pptApp.ActiveWindow.Selection.ShapeRange
.Left = 456
.Top = 20
End With
End With
lngSlideKount = lngSlideKount + 1
Next objChartObject
End If
Next ws
' Now check CHART sheets:
For Each objCht In ActiveWorkbook.Charts
'ppLayoutBlank = 12
Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
With objCht
'Copy chart object as picture
.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
lngSlideKount = lngSlideKount + 1
Next objCht
'
'Activate PowerPoint application
pptApp.ActiveWindow.ViewType = ppViewNormal
pptApp.Visible = True
pptApp.Activate
If lngSlideKount > 0 Then
If lngSlideKount = 1 Then
MsgBox "1 chart was copied to PowerPoint", vbOKOnly + vbInformation, "Information"
Else
MsgBox lngSlideKount & " charts were copied to PowerPoint", vbOKOnly + vbInformation, "Information"
End If
End If
End Sub
Appreciate the help everyone!
There doesn't appear to be a nice easy .IsSelected property in Excel for Charts so you need to analyse the selection as in this function which you can call from your procedure to get a collection of selected charts (testing to make sure it's not Nothing before processing each Item in the Collection):
Option Explicit
' ***********************************************************
' Purpose: Get a collection of selected chart objects.
' Inputs: None.
' Outputs: Returns a collection of selected charts.
' Author: Jamie Garroch
' Company: YOUpresent Ltd. http://youpresent.co.uk/
' ***********************************************************
Function GetSelectedCharts() As Collection
Dim oShp As Shape
Dim oChartObjects As Variant
Set oChartObjects = New Collection
' If a single chart is selected, the returned type is ChartArea
' If multiple charts are selected, the returned type is DrawingObjects
Select Case TypeName(Selection)
Case "ChartArea"
oChartObjects.Add ActiveChart
Case "DrawingObjects"
For Each oShp In Selection.ShapeRange
If oShp.Type = msoChart Then
Debug.Print oShp.Chart.Name
oChartObjects.Add oShp.Chart
End If
Next
End Select
Set GetSelectedCharts = oChartObjects
Set oChartObjects = Nothing
End Function
So here's a solution that worked for me. The macro copy + pastes selected range or chart into the active PowerPoint slide into a certain position. This reason I wanted to do this is that each quarter/month we generate reports for our clients and this helps to reduce the time required for copying + pasting and making the deck look nice. Hope this helps anyone else who make a ton of PPTs!
'Export and position into Active Powerpoint
'Prior to running macro, enable Microsoft Powerpoint Object Library in Tools - Reference
'Identifies selection as either range or chart
Sub ButtonToPresentation()
If TypeName(Selection) = "Range" Then
Call RangeToPresentation
Else
Call ChartToPresentation
End If
End Sub
Sub RangeToPresentation()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
'Error message if range is not selected
If Not TypeName(Selection) = "Range" Then
MsgBox "Please select a worksheet range and try again."
Else
'Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
'Reference active presentation
Set PPPres = PPApp.ActivePresentation
'Reference active slide
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
'Copy the range as a picture
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
'Paste the range
PPSlide.Shapes.Paste.Select
'Align the pasted range
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End If
End Sub
Sub ChartToPresentation()
'Uses Late Binding to the PowerPoint Object Model
'No reference required to PowerPoint Object Library
Dim PPApp As Object 'As PowerPoint.Application
Dim PPPres As Object 'As PowerPoint.Presentation
Dim PPSlide As Object 'As PowerPoint.Slide
'Error message if chart is not selected
If ActiveChart Is Nothing Then
MsgBox "Please select a chart and try again."
Else
'Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
'Reference active presentation
Set PPPres = PPApp.ActivePresentation
'PPApp.ActiveWindow.ViewType = 1 ' 1 = ppViewSlide
'Reference active slide
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
'Copy chart as a picture
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
Format:=xlPicture
'Paste chart
PPSlide.Shapes.Paste.Select
'Align pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End If
End Sub
I am trying to create charts and tables in excel and then copy them to slides in powerpoint all through a PowerPoint VBA macro. I have the charts and tables created but I am having an issue with copying and pasting them over. I am not familiar with the syntax to do so. Any help would be greatly appreciated as I am new to PowerPoint VBA.
Sub GenerateVisual()
Dim dlgOpen As FileDialog
Dim folder As String
Dim excelApp As Object
Dim xlWorkBook As Object
Dim xlWorkBook2 As Object
Dim PPT As Presentation
Dim Name1 As String
Dim Name2 As String
Set PPT = ActivePresentation
Set excelApp = CreateObject("Excel.Application")
excelApp.Visible = True
Set xlWorkBook = excelApp.workbooks.Open("C:\Users\wzawisa\Downloads\MarketSegmentTotals.xls")
xlWorkBook.Sheets("MarketSegmentTotals").Activate
xlWorkBook.ActiveSheet.Shapes.AddChart.Select
xlWorkBook.ActiveChart.ChartType = xlColumnClustered
xlWorkBook.ActiveChart.SetSourceData Source:=xlWorkBook.ActiveSheet.Range("MarketSegmentTotals!$A$1:$F$2")
xlWorkBook.ActiveChart.Legend.Delete
xlWorkBook.ActiveChart.SetElement (msoElementChartTitleAboveChart)
xlWorkBook.ActiveChart.SetElement (msoElementDataLabelCenter)
xlWorkBook.ActiveChart.ChartTitle.Text = "DD Ready by Market Segment"
xlWorkBook.ActiveSheet.ListObjects.Add
xlWorkBook.ActiveSheet.ChartObjects(1).Select 'My attempt to copy them over but it doesnt work
PPT.ActiveWindow.View.Paste
End Sub
This sub will get you on your way. It needs some tweaks but this can copy over a range into a PPT:
Public Sub RangeToPresentation(sheetName, NamedRange)
Dim CopyRng As Range
Set CopyRng = Sheets(sheetName).Range(NamedRange)
Dim ppApp As Object
Dim ppPres As Object
Dim PPSlide As Object
If Not TypeName(CopyRng) = "Range" Then
MsgBox "Please select a worksheet range and try again.", vbExclamation, _
"No Range Selected"
Else
Set ppApp = GetObject(, "Powerpoint.Application")
Set ppPres = ppApp.ActivePresentation
ppApp.ActiveWindow.ViewType = ppViewNormal
Dim longSlideCount As Long
' Determine how many slides are in the presentation.
longSlideCount = ppPres.Slides.Count
With ppPres
' Insert a slide at the end of the presentation
Set PPSlide = ppPres.Slides.Add(longSlideCount + 1, ppLayoutBlank)
End With
' Select the last (blank slide)
longSlideCount = ppPres.Slides.Count
ppPres.Slides(longSlideCount).Select
Set PPSlide = ppPres.Slides(ppApp.ActiveWindow.Selection.SlideRange.SlideIndex)
CopyRng.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
' Paste the range
PPSlide.Shapes.Paste.Select
'Set the image to lock the aspect ratio
ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoTrue
'Set the image size slightly smaller than width of the PowerPoint Slide
ppApp.ActiveWindow.Selection.ShapeRange.Width = ppApp.ActivePresentation.PageSetup.SlideWidth - 10
ppApp.ActiveWindow.Selection.ShapeRange.Height = ppApp.ActivePresentation.PageSetup.SlideHeight - 10
'Shrink image if outside of slide borders
If ppApp.ActiveWindow.Selection.ShapeRange.Width > 700 Then
ppApp.ActiveWindow.Selection.ShapeRange.Width = 700
End If
If ppApp.ActiveWindow.Selection.ShapeRange.Height > 600 Then
ppApp.ActiveWindow.Selection.ShapeRange.Height = 600
End If
' Align the pasted range
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
' Clean up
Set PPSlide = Nothing
Set ppPres = Nothing
Set ppApp = Nothing
End If
End Sub
The code below takes the ranges specified in excel and imports the range to PowerPoint. My struggle is that i am trying to add a slide title for each slide in the code but the syntax below doesn’t work (Header1 = "test"). Can you help if possible? Thanks in advance!!
Sub export_to_powerpoint()
Dim PPAPP As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim SlideCount As Integer
Dim shptbl As Table
Set PPAPP = New PowerPoint.Application
Dim cht As Excel.ChartObject
Dim Header1 As String
PPAPP.Visible = True
'create new ppt:
Set PPPres = PPAPP.Presentations.Add
For ii = 1 To 10
PPPres.Slides.Add PPPres.Slides.Count + 1, ppLayoutTitleOnly
Next ii
PasteRng PPPres, 1, Range("A2:S24")
PPSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
Header1 = "test" 'Titel on the first slide
PPAPP.ActiveWindow.Selection.ShapeRange.Left = 5
PPAPP.ActiveWindow.Selection.ShapeRange.Top = 100
PPAPP.ActiveWindow.Selection.ShapeRange.ScaleHeight 0.8, msoTrue
PPAPP.ActiveWindow.Selection.ShapeRange.ScaleWidth 0.7, msoTrue
PPAPP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPAPP.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
PasteRng PPPres, 2, Range("A25:S47")
PPAPP.ActiveWindow.Selection.ShapeRange.Left = 5
PPAPP.ActiveWindow.Selection.ShapeRange.Top = 100
PPAPP.ActiveWindow.Selection.ShapeRange.ScaleHeight 0.8, msoTrue
PPAPP.ActiveWindow.Selection.ShapeRange.ScaleWidth 0.7, msoTrue
PPAPP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPAPP.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
PasteRng PPPres, 3, Range("v2:am24")
'Adjust the positioning of the Chart on Powerpoint Slide
PPAPP.ActiveWindow.Selection.ShapeRange.Left = 5
PPAPP.ActiveWindow.Selection.ShapeRange.Top = 100
PPAPP.ActiveWindow.Selection.ShapeRange.ScaleHeight 0.8, msoTrue
PPAPP.ActiveWindow.Selection.ShapeRange.ScaleWidth 0.7, msoTrue
PPAPP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPAPP.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPAPP = Nothing
End Sub
Sub PasteRng(Pres, SlideNo, Rng As Range)
Rng.Copy ' copy the range
Pres.Application.ActiveWindow.View.GotoSlide SlideNo 'PPSlide.SlideIndex ' activate the slide no
Pres.Application.ActiveWindow.View.PasteSpecial ppPasteOLEObject, msoFalse ' paste using pastespecial method
End Sub
Your code works. It's doing exactly what you asked it to do (which may differ from what you expect...), when you
Dim Header1 as String
You create a string variable, capable of holding a string data.
Then you assign to it:
Header1 = "test" 'Titel on the first slide
Nowhere in your code have you even attempted to use this string to write to a slide's title. you need to assign this to the slide's title object.
Header1 = "test"
Dim sldTitle as Object
If Not ppSlide.Shapes.HasTitle Then
'If there is no title object then assume the slideLayout does not permit one
' so do nothing.
Else:
Set myTitle = ppSlide.Shapes.Title
'Assign the title text:
myTitle.TextFrame.TextRange.Characters.Text = Header1
End If
This will come in handy for you:
http://msdn.microsoft.com/en-us/library/office/ff743835(v=office.14).aspx