-
It's indeed becoming quite tricky. However, as always, I really appreciate your help!
I followed your logic and made sure that there weren't any "RangeToCopy1/2" ranges in the sheets that include a chart. The other sheets do have these. However, when I run the query, it gives me the following error: "Selection (unknown member): Invalid request. Nothing approriate is currently selected. I assumed that I had to literally select the charts on the slide, so it could copy-paste them, but unfortunately without result.
Code:
Option Explicit
Sub PPT()
Dim iName As Long
Dim rName As Range
Dim nRange As Long
Dim dSlideCenter As Double
Dim pptApp As PowerPoint.Application
Dim pptPre As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
Dim objSheet As Worksheet
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPre = pptApp.Presentations.Add
' loop the sheets
For Each objSheet In ActiveWorkbook.Worksheets
'Create new slide for the data
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, ppLayoutBlank)
If WorksheetFunction.Count(objSheet.UsedRange) > 0 Then
' Data in sheet so copy used range(s)
For iName = 1 To 2
' initialize
Set rName = Nothing
nRange = 0
' look for named range
On Error Resume Next
Set rName = objSheet.Range("RangeToCopy" & CStr(iName))
On Error GoTo 0
If Not rName Is Nothing Then
' counter
nRange = nRange + 1
' copy range as picture
rName.CopyPicture Appearance:=xlScreen, Format:=xlPicture
' paste the copied picture
pptSld.Shapes.Paste
' Align pasted shape
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
End If
Next
Else
' No data in sheet, so copy chart
objSheet.ChartObjects(1).Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' paste the copied picture
pptSld.Shapes.Paste
End If
' Align pasted shape
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
If nRange = 2 Then
With pptSld.Shapes(pptSld.Shapes.Count - 1) ' first shape of two
dSlideCenter = .Left + .Width / 2
.Left = 1.5 * dSlideCenter - .Width / 2 ' center shape in left half of slide
End With
With pptSld.Shapes(pptSld.Shapes.Count) ' last shape of two
.Left = 1.5 * dSlideCenter + .Width / 2 ' center shape in right half of slide
End With
End If
Next
End Sub
Highlighting the piece of code doesn't work, but it seems to get stuck on this part: pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True.
When it didn't work I have tried to do it with "RangeToCopy1" ranges in the sheets that include charts, but it gives the same error.
Many thanks again.
Yours sincerely,
Djani
-
The pasted shape is not necessarily selected.
Try this (Declare oshpR as PowerPoint.ShapeRange)
Code:
If Not rName Is Nothing Then ' counter
nRange = nRange + 1
' copy range as picture
rName.CopyPicture Appearance:=xlScreen, Format:=xlPicture
' paste the copied picture
Set oshpR = pptSld.Shapes.Paste
' Align pasted shape
oshpR.Align msoAlignCenters, True
oshpR.Align msoAlignMiddles, True
End If
Next
Else
' No data in sheet, so copy chart
objSheet.ChartObjects(1).Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' paste the copied picture
Set oshpR = pptSld.Shapes.Paste
End If
' Align pasted shape
oshpR.Align msoAlignCenters, True
oshpR.Align msoAlignMiddles, True
-
Dear John,
Thanks for your time to help me out. It's working perfect. For everyone else: down below is the properly working VBA script which automates multiple tables from one/multiple sheet(s) to one/multiple slide(s). I hope this will benefit many of you.
Code:
Option Explicit
Sub PPT()
Dim iName As Long
Dim rName As Range
Dim nRange As Long
Dim dSlideCenter As Double
Dim pptApp As PowerPoint.Application
Dim pptPre As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
Dim objSheet As Worksheet
Dim oshpR As PowerPoint.ShapeRange
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPre = pptApp.Presentations.Add
' loop the sheets
For Each objSheet In ActiveWorkbook.Worksheets
'Create new slide for the data
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, ppLayoutBlank)
If WorksheetFunction.Count(objSheet.UsedRange) > 0 Then
' Data in sheet so copy used range(s)
For iName = 1 To 2
' initialize
Set rName = Nothing
nRange = 0
' look for named range
On Error Resume Next
Set rName = objSheet.Range("RangeToCopy" & CStr(iName))
On Error GoTo 0
If Not rName Is Nothing Then ' counter
nRange = nRange + 1
' copy range as picture
rName.CopyPicture Appearance:=xlScreen, Format:=xlPicture
' paste the copied picture
Set oshpR = pptSld.Shapes.Paste
' Align pasted shape
oshpR.Align msoAlignCenters, True
oshpR.Align msoAlignMiddles, True
End If
Next
Else
' No data in sheet, so copy chart
objSheet.ChartObjects(1).Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' paste the copied picture
Set oshpR = pptSld.Shapes.Paste
End If
' Align pasted shape
oshpR.Align msoAlignCenters, True
oshpR.Align msoAlignMiddles, True
If nRange = 2 Then
With pptSld.Shapes(pptSld.Shapes.Count - 1) ' first shape of two
dSlideCenter = .Left + .Width / 2
.Left = 1.5 * dSlideCenter - .Width / 2 ' center shape in left half of slide
End With
With pptSld.Shapes(pptSld.Shapes.Count) ' last shape of two
.Left = 1.5 * dSlideCenter + .Width / 2 ' center shape in right half of slide
End With
End If
Next
End Sub
Many thanks for giving the final missing code.
Yours sincerely,
Djani
-
However, I do have one question. When the PowerPoint is being opened, is it possible to have it opened with the company's Theme Color? The company I'm working requires this for every PowerPoint. I believe you mentioned a freeware on a different forum (nattyware/pixie), but I can't download it at this moment since it's blocked at work. The location of the file (that includes the layout/office theme) is "H:\My Documents\PPT Automation". The name of the layout is called: "OC-E PPT template - September". The VBA script down below is what I have thus far:
Code:
Sub Test()
With ActivePresentation
.Slides.AddSlide .Slides.Count + 1, .Designs(1).SlideMaster.CustomLayouts(GetLayoutIndexFromName("OC-E PPT template - September", .Designs(1)))
End With
End Sub
Function GetLayoutIndexFromName(sLayoutName As String, oDes As Design) As Long
Dim x As Long
For x = 1 To oDes.SlideMaster.CustomLayouts.Count
If oDes.SlideMaster.CustomLayouts(x).Name = sLayoutName Then
GetLayoutIndexFromName = x
Exit Function
End If
Next
End Function
As of right now, it's not working. It gives the error: "ActiveX component can't create object."
Is it possible - in addition to the previous VBA script - to give the newly opened PPT the respected layout and Office Theme?
Yours sincerely,
Djani
-
Not quite sure I understand but if you rename the default template to Blank.potx and place it in C:\Users\Name\Appdata\Roaming\Microsoft\Templates\ it should open with PowerPoint
-
Thanks for your quick reply.
Basically, I want to apply a specific custom template to all slides in the PowerPoint that is being opened with the latest VBA script. The company I'm working for has a set "Office Theme" which includes the colours/layout etc. However, I am unable to 'extract' the specifications of the custom made templade since it's locked by another user from another company entity. Since I do know the name of the template (which won't change in the near future) I was thinking of referring to this name. When opening a PPT it should immediately adopt the custom made template.
I am not sure whether I can explain it in any different way, but let me know if anything is unclear.
-
You can just use ApplyTemplate but you need to know the full path not just the name
pptPre.ApplyTemplate ("Full path to template")
-
It gives me the following error: "Presentation (unknown member): Object does not exist. I assume it has something to do with defining the variables. Do I have to define another one in order to use: pptPre.ApplyTemplate ("C:\Users\NE70090\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors"). It refers to this code of line by the way.
The path is referring to the .potx presentation with the respected office theme.
Code:
Option Explicit
Sub PPT()
Dim iName As Long
Dim rName As Range
Dim nRange As Long
Dim dSlideCenter As Double
Dim pptApp As PowerPoint.Application
Dim pptPre As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
Dim objSheet As Worksheet
Dim oshpR As PowerPoint.ShapeRange
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPre = pptApp.Presentations.Add
' loop the sheets
For Each objSheet In ActiveWorkbook.Worksheets
'Create new slide for the data
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, ppLayoutBlank)
pptPre.ApplyTemplate ("C:\Users\NE70090\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors")
If WorksheetFunction.Count(objSheet.UsedRange) > 0 Then
' Data in sheet so copy used range(s)
For iName = 1 To 2
' initialize
Set rName = Nothing
nRange = 0
' look for named range
On Error Resume Next
Set rName = objSheet.Range("RangeToCopy" & CStr(iName))
On Error GoTo 0
If Not rName Is Nothing Then ' counter
nRange = nRange + 1
' copy range as picture
rName.CopyPicture Appearance:=xlScreen, Format:=xlPicture
' paste the copied picture
Set oshpR = pptSld.Shapes.Paste
' Align pasted shape
oshpR.Align msoAlignCenters, True
oshpR.Align msoAlignMiddles, True
End If
Next
Else
' No data in sheet, so copy chart
objSheet.ChartObjects(1).Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' paste the copied picture
Set oshpR = pptSld.Shapes.Paste
End If
' Align pasted shape
oshpR.Align msoAlignCenters, True
oshpR.Align msoAlignMiddles, True
If nRange = 2 Then
With pptSld.Shapes(pptSld.Shapes.Count - 1) ' first shape of two
dSlideCenter = .Left + .Width / 2
.Left = 1.5 * dSlideCenter - .Width / 2 ' center shape in left half of slide
End With
With pptSld.Shapes(pptSld.Shapes.Count) ' last shape of two
.Left = 1.5 * dSlideCenter + .Width / 2 ' center shape in right half of slide
End With
End If
Next
End Sub
Many thanks in advance!
-
Theme Colors cannot be the full name of the template. It looks like a folder to me. If you are trying to apply a COLOR SCHEME from this folder you will need different code. You need to state CLEARLY the name you are trying to apply including the extension (.xml for a color scheme, .potx or .thmx for a template / theme)
ActivePresentation.SlideMaster.Theme.ThemeColorScheme.Load (Path to xml color scheme)
-
I have saved the custom Template to Blank.potx and it does open the PowerPoint with the respected layout/office theme. However, when I run the macro, the PowerPoint is opened in 'normal layout'
--> It is blank for some reason (excl. the tables/graphs ofcourse).
I have also tried to use the abovementioned code, but I have some troubles with it. It keeps saying "ActiveX component can't create object" even though I'm referring to the right path.
Code:
Sub PPT()
Dim iName As Long
Dim rName As Range
Dim nRange As Long
Dim dSlideCenter As Double
Dim pptApp As PowerPoint.Application
Dim pptPre As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
Dim objSheet As Worksheet
Dim oshpR As PowerPoint.ShapeRange
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPre = pptApp.Presentations.Add
' loop the sheets
For Each objSheet In ActiveWorkbook.Worksheets
'Create new slide for the data
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, ppLayoutBlank)
ActivePresentation.SlideMaster.Theme.ThemeColorScheme.Load ("C:\Users\NE70090\AppData\Roaming\Microsoft\Templates")
If WorksheetFunction.Count(objSheet.UsedRange) > 0 Then
' Data in sheet so copy used range(s)
Many thanks as always.
-
If you have the template saved just open it.
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True
Set pptPre = pptApp.Presentations.Open(Filename:=Environ("APPDATA") & "\Microsoft\Templates\blank.potx", _
Untitled:=True)
Set pptSld = pptPre.Slides.Add(1, ppLayoutBlank)
-
It's working perfect, but in combination with the other VBA script it's opening multiple PowerPoints --> each PowerPoint contains one or multiple tables/graphs.
It looks like the script is 'spitting out' the different objects in different PowerPoints, resulting in opening 10 to 20 PowerPoints.
The VBA script I have now contains pretty much all elements, but I believe it's not in the right order. Is it possible to open the PowerPoint with the amount of slides based on the "ranges" that's coming from the report? Let's say there are 6 "ranges" - defined with "RangeToCopy"- divided over 3 worksheets. Is there any way to create the following order before it pastes:
1. Open new PowerPoint (with desired layout);
2. Count how many "ranges" there are in the report:
3. Based on the "ranges" the PowerPoint will make an additional x amount of slides:
4. "RangeToCopy1" goes to PPT slide 1/"RangeToCopy4" goes to PPT slide 4 etc.
I am not sure if this is possible, but can you share your thoughts on this?
Yours sincerely,
Djani
-
1 Attachment(s)
Hi John,
Sorry for resurrecting the topic again, but I got a question that is related to this topic. I am asking for some advice. I am going to have a dynamic chart and I want others to click on it so that the chart will be put in the active PowerPoint. This piece of code is found on JonPeltier (thanks for that), so that part of the challenge is solved. The PowerPoints have a solid structure that doesn't change. Is it possible to put the chart into a specific slide of the active PowerPoint while referring to 2 criteria? The chart has 2 slicers --> 1 for countries (2x) and 1 for models (x9) = 18 possible combinations. E.g. if you have the combination "POR" & NOTE" it will be put in slide 8, if you have the combination "SPA" & "MICRA" it will be put in slide 9 etc.
I have put a file in the attachments so you can understand what I mean. The two variables are to be found in cell B19:B20 which refers to the linked dataset.
Many thanks in advance,
Djani Sadloe
-
At some point, shouldn't you just provide the workbook? Using PowerPoint for a job best suited for Excel is making your job difficult. (I actually saw a statistic within the past couple weeks that showed Excel is used more for business presentations than PowerPoint.)
To directly answer your question, yes, it's possible to have VBA send a picture of a chart to a specific slide depending on the settings of a couple slicers. But it's starting to get into the realm of an actual contract programming project to work out all the specific details.
-
You're totally right. However, without sounding a bit delusional (lol), is there no other/easier way to do it like this? I feel like with your code it covers already 80% of the problem.
Code:
Sub ChartToPresentation()
' Uses Early Binding to the PowerPoint Object Model
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
' Make sure a chart is selected
If ActiveChart Is Nothing Then
MsgBox "Please select a chart and try again.", vbExclamation, _
"No Chart Selected"
Else
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = 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
Isn't it possible to play with the following subcode? Instead of referring to the active slice in the PPT to a desired one?
Code:
' Reference active slide
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
Yours sincerely,
Djani
-
The various versions of code either paste an object onto a new slide or onto the active slide. Of course you can paste onto any existing slide, simply using something like this:
Code:
' Reference slide 3
Set PPSlide = PPPres.Slides(3)
If this is what you want, didn't you at least try it?
-
Dear John,
Yes, it's part of the solution as well. You are pushing me to the right direction. It starts to get interesting. What if I make a 'variable table' where I define the existing combinations and give them a specific number. Instead of giving the code a 'hard number' such as 3 I make it refer to a specific cell that uses the VLOOKUP function to check the respected number --> e.g. B2 or whatever?
Something like this:
http://i63.tinypic.com/omq0y.png
Yours sincerely,
Djani
-
-
I came up with the following script:
Code:
Sub ChartToPresentation()
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Dim shp As String
Dim newShape As PowerPoint.ShapeRange
Dim cell As Range
Dim rng As Range
Dim RangeName As String
Dim CellName As String
' Make sure a chart is selected
If ActiveChart Is Nothing Then
MsgBox "Please select a chart and try again.", vbExclamation, _
"No Chart Selected"
Else
' Reference existing instance of PowerPoint
Set ppApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set ppPres = ppApp.ActivePresentation
' Reference active slide
RangeName = "PPTSlide"
CellName = "B6"
Set cell = Worksheets("VIVA GRAPH").Range(CellName)
Worksheets("VIVA GRAPH").Names.Add Name:=RangeName, RefersTo:=cell
' Copy chart as a picture
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
Format:=xlPicture
' Paste chart
Set newShape = ppSlide.Shapes.Paste
With newShape
.IncrementLeft 400
.IncrementTop 250
.ScaleWidth 0.87, msoFalse, msoScaleFromTopLeft
.ScaleHeight 0.87, msoFalse, msoScaleFromTopLeft
End With
' Clean up
Set ppSlide = Nothing
Set ppPres = Nothing
Set ppApp = Nothing
End If
End Sub
I am referring to the sheet "VIVA GRAPH" and made a range (via Name Manager) called "PPTSlide" that is linked to cell B6. However, it gives "Object variable or With block variable not set" at this piece of code: Set newShape = ppSlide.Shapes.Paste.
What am I missing?
Yours sincerely,
Djani
-
"Object variable or With block variable not set"
You haven't set something in the line that gives the error. In this case, you have not defined the slide. You must have taken out the slide definition when you inserted RangeName = "PPTSlide".