PDA

View Full Version : Copy each excel worksheets and paste in each indivual slides



Shazam
03-01-2006, 05:56 PM
Here is the link I ask the question the first time.

http://vbaexpress.com/forum/showthread.php?p=59284#post59284


Can this code could be modified to work in power point?


Option Explicit

Sub CombineFiles()

Dim Path As String
Dim FileName As String
Dim Wkb As Workbook
Dim WS As Worksheet

Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "S:\Conference\Presentaions" 'Change as needed
FileName = Dir(Path & "\*.xls", vbNormal)
Do Until FileName = ""
Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
For Each WS In Wkb.Worksheets
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Next WS
Wkb.Close False
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

The reason is right now I'm showing all these worksheet tabs on a projector using excel at the production meeting. Can I run a macro on Excel or power point that it will copy each worksheet that are group objects and paste it in each individual slide in power point?

I found this code but it does not do exactly how I would like it.



Sub CopyXLChart()
Dim xlApp As Object
Dim xlWrkBook As Object
Set xlApp = CreateObject("Excel.Application")
Set xlWrkBook = lApp.Workbooks.Open"S:\Conference\PresentaionsChart as of 10-19-2005.xls")

' Copy the 1st chart object on the 1st worksheet
' you can use Cut instead.
xlWrkBook.Worksheets(1).GroupObjects(1).Copy

'Pastes the contents of the Clipboard into the active view.
'Attempting to paste an object into a view that won't accept
'will cause an error. Look up the help file for more info.

ActiveWindow.View.Paste

' Close the open workbook.
' I have set the flag to FALSE so that in case I make any changes
' to the XL file I don't want to be prompted with the Save Dialog.
' No changes are saved
xlWrkBook.Close False
xlApp.Quit

Set xlApp = Nothing
Set xlWrkBook = Nothing
End Sub

Ken Puls
03-01-2006, 09:25 PM
Hi Shazam,

Something to get you started, maybe. It's a late bind from Excel which pushes the used range to a powerpoint slide:

Public Sub TransferToPPT()
Dim objSheet As Worksheet
Dim pptApp As Object
Dim pptPre As Object
Dim pptSld As Object

'Create a new Powerpoint session
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPre = pptApp.Presentations.Add

'Loop through each worksheet
For Each objSheet In ActiveWorkbook.Worksheets
'Create new slide for the data
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, 12) 'ppLayoutBlank = 12
objSheet.UsedRange.Copy
pptSld.Shapes.Paste
Next objSheet

'Activate PowerPoint application
pptApp.Visible = True
pptApp.Activate
End Sub

HTH,

Shazam
03-02-2006, 07:23 AM
Thanks Ken Puls,


I used your code and I change it to pick up group objects. But its not really perfect. The first slide is transparent and can it be fit on the total slide? right now some of the charts is going over the slide.




Public Sub TransferToPPT()
Dim objSheet As Worksheet
Dim pptApp As Object
Dim pptPre As Object
Dim pptSld As Object
Dim Ch As Chart
Dim Wkb As Workbook


'Create a new Powerpoint session
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPre = pptApp.Presentations.Add

'Loop through each worksheet
For Each objSheet In ActiveWorkbook.Worksheets
'Create new slide for the data
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, 12) 'ppLayoutBlank = 12
objSheet.GroupObjects.Copy
pptSld.Shapes.Paste

Next objSheet

'Activate PowerPoint application
pptApp.Visible = True
pptApp.Activate
End Sub

Ken Puls
03-02-2006, 09:16 AM
H Shazam,

To be completely honest, powerpoint isn't my strong suit. :(

I'm wondering, though... can you change the size of the shape that you're pasting the groupobject to? You may need to create a new shape on the slide, right after you create, in order to set it to a variable. Something like:

set pptShp = pptSld.Shapes.Add
With pptShp
.Left = 10
.Right = 100
End With

Just a note... NONE of the above has been tested. I was musing over the method only, and have no idea if the object model supports what I've given you there. You'll need to do some sleuthing in powerpoint to verify.

If you can wait till tonight, I can take a play with it then.

Cheers,

Shazam
03-02-2006, 03:12 PM
No prolblem Ken Puls I'll wait.

Ken Puls
03-02-2006, 03:53 PM
I'll give it a shot tonight.

Is there any way you can upload a santized workbook to work with? It would save me guessing on the output. :)

JonPeltier
03-06-2006, 08:02 PM
I recommend you have a look at this web page. It has several examples showing how to get Excel content into PowerPoint. The last example also shows the syntax to scale the pasted object; adjust the scaling factor to fit the slide.

http://peltiertech.com/Excel/XL_PPT.html

Ken Puls
03-06-2006, 09:46 PM
Fabulous!

Jon, I have used and referred others to your site for anything Excel Chart related, but somehow I missed that page. There's some great stuff in there.

:thumb

Shazam
03-07-2006, 09:50 PM
Ok it took me awhile to complete this because I'm still learning vba. The only problem is I can't figuer it out how to center the pictures on the sildes. If anyone has any ideas that will be great. Also I will like to thanks Ken Puls:beerchug: for setting me in the right direction. For this code to work you need to put a asterisk "*" or some kind of last vaule. Look at the sample workbook below it will have a red asterisk in each worksheet so the code could determine where to select the range. Use the code below on the sample workbook then you will get a better understanding how this code works.


Remember to set your reference library.

Microsoft PowerPoint 11.0 Object Library




Sub CopyToPowerPoint()
Dim pptApp As Object
Dim pptPre As Object
Dim pptSld As Object
Dim PP_Presentation As PowerPoint.Presentation
Dim L As Long, ws As Worksheet
Dim rngSel As Range
Dim objSheet As Worksheet
Dim wks As Worksheet
Dim wb As Workbook

'Shazam!!
'Created final version 03-07-2006

With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
.AskToUpdateLinks = False


On Error Resume Next
'This will loop through all the worksheets in your workbook to select a range where you want to copy your range.
'Need to put some kind a last vaule for your range to select your range.
For Each objSheet In ActiveWorkbook.Worksheets
objSheet.Activate
Set rngSel = IncreaseUsedRange(ActiveSheet)
rngSel.Select
Next objSheet
For L = 1 To Worksheets.Count
Set ws = Worksheets(L)
ws.Activate

' This will copy all ranges that you selected in your workbook and convert it into a picture
For Each objSheet In ThisWorkbook.Worksheets
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
'After copying your ranges as pictures it will delete the active cells
Selection.Delete
'Delete All active charts in your workbook
ActiveSheet.ChartObject.Activate
ActiveChart.ChartArea.Select
ActiveWindow.Visible = False
Selection.Delete
'Need to keep your workbook visible
For Each wb In Workbooks
Windows(wb.Name).Visible = True
Next
'pasted all pictures from your selected ranges
ActiveSheet.Paste
Next objSheet
' Starting your next objective
Next
'Create a new Powerpoint session
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPre = pptApp.Presentations.Add

'Loop through each worksheet
For Each objSheet In ActiveWorkbook.Worksheets
'Create new slide for the data
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, ppLayoutBlank)
objSheet.Pictures.Copy
pptSld.Shapes.Paste
Next objSheet
'Activate PowerPoint application
pptApp.Visible = True
pptApp.Activate
'Will save your file name with current date
pptApp.ActivePresentation.SaveAs FileName:="C:\Meeting" & " " & Format(Date, "mm-dd-yyyy")
On Error GoTo 0
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
.AskToUpdateLinks = True
End With
End Sub
Public Function IncreaseUsedRange(ws As Worksheet) As Range
'Function Purpose: Returns range from cell A1 to the last used cell
' and then increases the range by one row and one column

Dim FirstRow As Long
Dim LastRow As Long
Dim FirstColumn As Integer
Dim LastColumn As Integer


On Error Resume Next
With ws
LastRow = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

LastColumn = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

Set IncreaseUsedRange = Range(.Cells(1, 1), .Cells(LastRow + 1, LastColumn + 1))

End With
On Error GoTo 0

End Function

mike31z
05-05-2007, 05:06 PM
Shazam Thanks for the code on excel to powerpoint.

I know you wrote this over a year ago but yours is the only that will allow me to comp anythin into PowerPoint. Yours copied to much. Can you assist me in limiting the range down to the amoutn selected on the current active worksheet.

mike in wisconsin.

JonPeltier
05-06-2007, 05:54 AM
Shazam's code is rather inefficient. It loops among the sheets in the workbook four times instead of the one time which would be required, it dumps a picture of each worksheet's used range into the worksheet, then copies all pictures in each worksheet, not just the picture of the used range, into a slide. Also, he sets a reference to the PowerPoint object library, but late binds most of the PowerPoint object variables (i.e., declares them As Object).

A more efficient way is following this untested code:
' instantiate powerpoint
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPre = pptApp.Presentations.Add

' loop the sheets
For Each objSheet in ActiveWorkbook.Worksheets
objSheet.activate
If TypeName(Selection) = "Range" Then
' copy the selection, if it's a range
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

'Create new slide for the data
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, ppLayoutBlank)

' paste the copied picture
pptSld.Shapes.Paste

End If
Next

mike31z
05-07-2007, 12:52 PM
Jon thanks for your help, I did a workaround and I like it.

Thanks

Mike in wisconsin

Darthvader
06-21-2011, 11:17 AM
Hi Jon

Can this code be modified to copy the contents of each sheet? (assume each sheet has contents fitting exactly one page). Thanks




Shazam's code is rather inefficient. It loops among the sheets in the workbook four times instead of the one time which would be required, it dumps a picture of each worksheet's used range into the worksheet, then copies all pictures in each worksheet, not just the picture of the used range, into a slide. Also, he sets a reference to the PowerPoint object library, but late binds most of the PowerPoint object variables (i.e., declares them As Object).

A more efficient way is following this untested code:
' instantiate powerpoint
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPre = pptApp.Presentations.Add

' loop the sheets
For Each objSheet in ActiveWorkbook.Worksheets
objSheet.activate
If TypeName(Selection) = "Range" Then
' copy the selection, if it's a range
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

'Create new slide for the data
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, ppLayoutBlank)

' paste the copied picture
pptSld.Shapes.Paste

End If
Next

JonPeltier
06-21-2011, 02:12 PM
That's pretty much what it does. What you could do is modify the range selection bit to use the print area of each sheet:

For Each objSheet In ActiveWorkbook.Worksheets
objSheet.Activate

ObjSheet.Range("Print_Area").CopyPicture Appearance:=xlScreen, Format:=xlPicture

'Create new slide for the data
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, ppLayoutBlank)

' paste the copied picture
pptSld.Shapes.Paste

Next

or simply copy the used range:

ObjSheet.UsedRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Darthvader
06-21-2011, 11:04 PM
Thanks :)

How would you modify this code if you were a) doing the same for a word document to powerpoint (1 page per slide) and b) doing the same for an existing powerpoint doc to a new pp doc (slide for slide)?

Kind Regards


That's pretty much what it does. What you could do is modify the range selection bit to use the print area of each sheet:

For Each objSheet In ActiveWorkbook.Worksheets
objSheet.Activate

ObjSheet.Range("Print_Area").CopyPicture Appearance:=xlScreen, Format:=xlPicture

'Create new slide for the data
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, ppLayoutBlank)

' paste the copied picture
pptSld.Shapes.Paste

Next

or simply copy the used range:

ObjSheet.UsedRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Djani
03-14-2016, 08:25 AM
Hi JonPeltier,

My apologies for bringing this topic back to life, but I have got a question regarding your VBA script. It's working perfectly, but is it also possible to paste the existing charts (from different worksheets) into the PPT automatically together with the arrays? I tried to click on the chart, but the PPT gives nothing back. Rest (arrays) works fine.

Yours sincerely,

Djani Sadloe

JonPeltier
03-14-2016, 08:37 AM
Djani -

Which bit of code are you using (I posted a few pieces earlier)? Are the charts embedded on the copied worksheet, embedded on other worksheets, or standalone chart sheets?

Djani
03-14-2016, 09:08 AM
Dear JonPeltier,

Thanks for the quick reply. This is the code I am currently using:

' instantiate powerpoint
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPre = pptApp.Presentations.Add

' loop the sheets
For Each objSheet In ActiveWorkbook.Worksheets
objSheet.Activate
If TypeName(Selection) = "Range" Then
' copy the selection, if it's a range
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

'Create new slide for the data
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, ppLayoutBlank)

' paste the copied picture
pptSld.Shapes.Paste

End If

Regarding the charts: its data is coming from a pivottable in another worksheet, so "embedded on other worksheets". Down below you will see a picture to confirm it.
15624Yours sincerely,

Djani

JonPeltier
03-14-2016, 09:20 AM
The chart is embedded in a worksheet? Doesn't the code hit its parent worksheet when it loops through the worksheets in the active workbook?

Your image is too small to see any relevant details.

Djani
03-14-2016, 09:46 AM
Your code 'walks through' every sheet indeed, so it hits the parent worksheet of the graph. However, if it's possible, it would be nice to have a combination of selected arrays and charts in the different slides of the PPT presentation.
Unfortunately I'm restricted with the amount of links so I'm unable to send you a tinypic URL. The photo you will see is also quite small, but it is the parent worksheet and the source of the graph.

Parent worksheet
15625

I hope this gives you a better understanding of what I'm referring to.

Many thanks

JonPeltier
03-14-2016, 10:00 AM
No, the pictures don't really help. The best is a clear description of the problem. I think we're getting somewhere.

Something like this might be what you need. Put each chart onto its own worksheet with no data on the sheet.


Set pptApp = CreateObject("PowerPoint.Application")
Set pptPre = pptApp.Presentations.Add

' loop the sheets
For Each objSheet In ActiveWorkbook.Worksheets If WorksheetFunction.Count(objSheet.UsedRange) > 0 Then
' Data in sheet so copy used range
objSheet.UsedRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Else
' No data in sheet, so copy chart
objSheet.ChartObjects(1).Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
End If

'Create new slide for the data
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, ppLayoutBlank)

' paste the copied picture
pptSld.Shapes.Paste

Next

Djani
03-14-2016, 10:29 AM
This gives a "Compile error: Syntax error". I believe the problem is in this area:

' loop the sheets
For Each objSheet In ActiveWorkbook.Worksheets If WorksheetFunction.Count(objSheet.UsedRange) > 0 Then
' Data in sheet so copy used range
objSheet.UsedRange[/COLOR][COLOR=#333333].CopyPicture Appearance:=xlScreen, Format:=xlPicture

I tried to split the code in half, but it gives "wrong number of arguments or invalid property assignment".

However, to get back to the topic, the first macro I posted of yours is working fine, which takes the arrays (per sheet) I selected. The only problem is that the report is a mix between tables and embedded charts in different sheets. The only thing the macro is currently missing is the fact that it doesn't take the graphs. I also tried to make them standalone, but without result unfortunately.

Djani
03-14-2016, 10:31 AM
I do have something else though. That might be a little bit easier for me to explain and for you to understand. The only challenge I am facing for this is creating a "MyRange" per sheet. In the VBA script down below it takes the set "MyRange" for all sheets, but I would like to change that per sheet.

Sub WorkbooktoPowerPoint()

Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim xlwksht As Worksheet
Dim MyRange As String
Dim MyTitle As String

Set pp = CreateObject("PowerPoint.Application")
Set PPPres = pp.Presentations.Add
pp.Visible = True

MyRange = "C9:V32"

For Each xlwksht In ActiveWorkbook.Worksheets
xlwksht.Select
Application.Wait (Now + TimeValue("0:00:1"))
xlwksht.Range(MyRange).CopyPicture _
Appearance:=xlScreen, Format:=xlPicture

SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)
PPSlide.Select

PPSlide.Shapes.Paste.Select
pp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pp.ActiveWindow.Selection.ShapeRange.Top = 1
pp.ActiveWindow.Selection.ShapeRange.Left = 1
pp.ActiveWindow.Selection.ShapeRange.Width = 700


Next xlwksht

pp.Activate
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing

End Sub


For example:
"Sheet 1" = C9:V30
"Sheet 2" = C1:B25
etc.

Yours sincerely,

Djani Sadloe

JonPeltier
03-14-2016, 11:47 AM
Yeah, those stupid COLOR tags didn't belog. Somehow when I copied the code from above and typed it in, the editor inserted a lot of them and I only removed most of them. Try without these tags (I've corrected my post above).

JonPeltier
03-14-2016, 11:52 AM
On each sheet, define a Name ("Named Range") that contains what you want to copy:

Select the range.
On the Formulas tab, click Define Name.
In the dialog, enter a name, something like RangeToCopy
In the dropdown for Scope, select the active sheet's name.

Use the amended code:


Set pptApp = CreateObject("PowerPoint.Application")
Set pptPre = pptApp.Presentations.Add

' loop the sheets
For Each objSheet In ActiveWorkbook.Worksheets If WorksheetFunction.Count(objSheet.UsedRange) > 0 Then
' Data in sheet so copy used range
objSheet.Range("RangeToCopy").CopyPicture Appearance:=xlScreen, Format:=xlPicture
Else
' No data in sheet, so copy chart
objSheet.ChartObjects(1).Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
End If

'Create new slide for the data
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, ppLayoutBlank)

' paste the copied picture
pptSld.Shapes.Paste

Next

Djani
03-15-2016, 12:52 AM
Dear Jon,

Thanks for helping me out. I really appreciate it.

I have tested the script of your latest reply and it does work. However, when the macro is ran, it gives me the following error: "Application-defined or object-defined error".


Sub PPT()
' instantiate powerpoint
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPre = pptApp.Presentations.Add

' loop the sheets
For Each objSheet In ActiveWorkbook.Worksheets
If WorksheetFunction.Count(objSheet.UsedRange) > 0 Then
' Data in sheet so copy used range
objSheet.Range("RangeToCopy").CopyPicture Appearance:=xlScreen, Format:=xlPicture
Else
' No data in sheet, so copy chart
objSheet.ChartObjects(1).Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
End If

'Create new slide for the data
Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, ppLayoutBlank)

' paste the copied picture
pptSld.Shapes.Paste

Next
End Sub


The set ranges (scopes by Name Define) per sheet are all in the different slides in the PPT (as I wanted it to be), but for some reason it returns this error. VBA refers to the line which I made bold.

Yours sincerely,

Djani

Djani
03-15-2016, 01:25 AM
I have also taken a look at your site (PeltierTech Excel/XL_PPT) to align the arrays/charts in the middle of the PPT presentation. This is very helpful!
The following script works perfectly fine, but I need to adjust it to my needs somehow:

' Align pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

Do you have any tips on this point since I work with arrays instead of copy-pasting the chart(s)?

Yours sincerely,

Djani

Djani
03-15-2016, 03:57 AM
I am also facing another big challenge that is an addition to the latest VBA script of yours by working with "Name Define". I'll try my best to explain it by sketching the following scenario:

At this point there is a sheet that contains one table which is dynamic. The table allows us to make a choice on the model (9) and country (23) by selecting the criteria we want. However, as I am working with the "RangeToCopy" script, isn't it possible to create multiple "Name Defined" arrays that will be put into 1 slide? So let's say for example you will have a "RangeToCopy2".

Even though I'm not sure whether this is the best solution, because this indicates that I will have to make either 9 slides with 23 tables (per country) and thus 9 x 23 Name Defined arrays. Do you have any tips for this? The dynamic table really is the bottleneck in this case I believe.

I understand the photo will be small, but I have put it in the attachments so you have a better image of what I'm referring to.15649Yours sincerely,

Djani Sadloe

JonPeltier
03-15-2016, 05:37 AM
... it gives me the following error: "Application-defined or object-defined error".

Don't keep me in suspense. Where in the code does the error occur?

JonPeltier
03-15-2016, 05:40 AM
... since I work with arrays instead of copy-pasting the chart(s)

You keep saying "array". Do you mean "range"?

Notice that for ranges and for charts, my code is copying as a picture, and the result is a shape on the slide. ShapeRange.Align works on whatever is the recently pasted shape.

JonPeltier
03-15-2016, 05:47 AM
Where in the code does the error occur?

Sorry, I initially read the post in the notification email, which didn't show the bold line that had the error.

The error you posted occurs in the indicated line if the name does not exist on the sheet. Did you spell it correctly?

JonPeltier
03-15-2016, 05:57 AM
... isn't it possible to create multiple "Name Defined" arrays that will be put into 1 slide?

You can make this as complicated as you dare. You can use dynamic definitions for the Names in case the copied range changes size, and you can define multiple ranges in a sheet.

To make the code work with multiple ranges, name them "RangeToCopy1", "RangeToCopy2", etc. You may want to limit these to a small number, like 2 or at most 3.

Modify the code like this:


Dim iName As Long, rName As Range

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 3
' initialize
Set rName = Nothing

' 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
' copy range as picture
rName.CopyPicture Appearance:=xlScreen, Format:=xlPicture
' paste the copied picture
pptSld.Shapes.Paste
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

Next

Djani
03-15-2016, 06:31 AM
Dear Jon,

I'm indeed referring to "ranges", so my apologies for using the wrong terminology. Thanks again for your help. I'll get back to you whenever I have tested the code. Really appreciate it.

Regarding the error: I have checked if I misspelled the word "RangeToCopy" for the different ranges, but that doesn't seem to be the case. I am not sure what other reason there is to make this occur.

Have a good day.

Your sincerely,

Djani

Djani
03-15-2016, 07:08 AM
Dear Jon,

The query works perfect. I find it amazing that the script knows which "RangeToCopy" belongs to which sheet in the PowerPoint. One minor detail, every time I run the query, it adds 6 blank slides on top of the "filled slides" --> f.e. 5 filled slides + 6 blanks.

Regarding the dynamic table: do you imply that, in my case, I have to make multiple tables - each indicating its own country/model? This would be my solution whatsoever. However, I was looking if it was possible to make a range indicate a snapshot of the chosen criteria on the table at that moment. I had made a "RangeToCopy1" and "RangeToCopy2" on the same exact range/cells (each one with different criteria), but it took the same one unfortunately. It's difficult to explain without seeing it, but is this even possible?

Regarding the positioning: let's say I have "RangeToCopy1" and "RangeToCopy2" of a specific worksheet on 1PPT slide. How can I make the "RangeToCopy1" behave itself to the left side and "RangeToCopy2" on the right side?

Yours sincerely,

Djani

JonPeltier
03-15-2016, 07:55 AM
Positioning: The earlier snippets you found will center the shapes in the slide. You can also provide .top and .left properties to position and .height and .width properties to resize the shapes.

You need logic that:

If there is one shape, keep it centered.

If there are two shapes, move the first to the left and the second to the right by enough that they don't overlap. You may need to resize them as well if they are large.

A first cut (pseudocode):


dim dSlideCenter as double
with ppSld.Shapes(ppSld.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 ppSld.Shapes(ppSld.Shapes.Count) ' last shape of two
.left = 1.5 * dSlideCenter + .width/2 ' center shape in right half of slide
end with

JonPeltier
03-15-2016, 07:59 AM
Dynamic Table: If you have multiple things to filter, you need to apply one filter, copy and paste the range, apply another filter, copy and paste, etc. You could write this into the code, or you could make separate worksheets, each one filtered its own way, and use the existing code.

Djani
03-15-2016, 09:10 AM
Dear Jon,

Thanks for your advice. I am going to make a table per sheet to make it easier for myself. However, when I paste the two codes into the 'existing/working VBA script' it gives me the following error: Method 'Add' of object 'Slides' failed.

I might be doing it in the wrong order, since I am relatively new to VBA. This is the code as I have it right now:



Sub PPT()


Dim iName As Long, rName As Range

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 3
' initialize
Set rName = Nothing

' 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
' copy range as picture
rName.CopyPicture Appearance:=xlScreen, Format:=xlPicture
' paste the copied picture
pptSld.Shapes.Paste
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 chart
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

Dim dSlideCenter As Double
With ppSld.Shapes(ppSld.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 ppSld.Shapes(ppSld.Shapes.Count) ' last shape of two
.Left = 1.5 * dSlideCenter + .Width / 2 ' center shape in right half of slide
End With



It occurs at this piece of code: Set pptSld = pptPre.Slides.Add(pptPre.Slides.Count + 1, ppLayoutBlank)

Yours sincerely,

Djani

JonPeltier
03-15-2016, 09:39 AM
Hasn't that line of code been working already? Have you declared pptSld?

Do you have Option Explicit at the top of the code module?

Djani
03-15-2016, 09:59 AM
I haven't got the "Option Explicit" on top of the code module --> this is for defining variables right?

The script you see is everything I have. It has been working, but only when I leave the two tiny cuts of codes (one for centralization, one for putting tables/charts next to each other) out of it. As soon as I paste these scripts into the original "RangeToCopy" script then it gives the abovementioned error.

JonPeltier
03-15-2016, 05:24 PM
Okay, I've cleaned up the code. This is the entire module.

I have not tested it, but I've looked it over pretty carefully, with your reported errors in mind. I've tried to use consistent variable names; the problem with copy-paste programming is that different snippets use different variable names and may have other subtle differences. Copy-Paste programming isn't bad, necessarily, I do it all the time, but you have to be aware of the gotchas.

I assume only 1 or 2 named ranges on a sheet, or one chart if there are no named ranges.


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 ppSld.Shapes(ppSld.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 ppSld.Shapes(ppSld.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

Djani
03-16-2016, 12:31 AM
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.



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

John Wilson
03-16-2016, 01:44 AM
The pasted shape is not necessarily selected.

Try this (Declare oshpR as PowerPoint.ShapeRange)


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

Djani
03-16-2016, 02:31 AM
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.



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

Djani
03-16-2016, 02:35 AM
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:




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

John Wilson
03-16-2016, 02:52 AM
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

Djani
03-16-2016, 03:36 AM
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.

John Wilson
03-16-2016, 03:50 AM
You can just use ApplyTemplate but you need to know the full path not just the name

pptPre.ApplyTemplate ("Full path to template")

Djani
03-16-2016, 04:09 AM
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.




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!

John Wilson
03-16-2016, 04:29 AM
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)

Djani
03-16-2016, 06:16 AM
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.




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.

John Wilson
03-16-2016, 07:08 AM
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)

Djani
03-16-2016, 07:41 AM
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

Djani
03-21-2016, 12:56 AM
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

JonPeltier
03-21-2016, 04:41 AM
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.

Djani
03-21-2016, 07:50 AM
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.



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?



' Reference active slide
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)


Yours sincerely,

Djani

JonPeltier
03-21-2016, 08:11 AM
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:


' Reference slide 3
Set PPSlide = PPPres.Slides(3)

If this is what you want, didn't you at least try it?

Djani
03-21-2016, 09:18 AM
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

JonPeltier
03-21-2016, 12:44 PM
Something like that.

Djani
03-22-2016, 05:49 AM
I came up with the following script:



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

JonPeltier
03-22-2016, 06:01 AM
"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".

Djani
03-22-2016, 06:24 AM
I have indeed left out this piece of code:




Set ppSlide = ppPres.Slides(5)



However, this is the 'hard value'. It does work whenever I put this piece of code back into the script, but it doesn't change/manipulate the behavior --> it is set. I want the script to refer to cell B6 since this cell VLOOKUPs the combination of country and model --> returns desired PPT slide. I have left this out, because I can't simply do the following right?




Set ppSlide = ppPres.Slides(Worksheets("VIVA GRAPH").B6)



Correct me if I'm wrong, but in this case the slide is defined as a cell, which can't ever be the case. I have tried some other things, but it doesn't lead me to a solution. This is what I have:




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 rng As Range
Dim cell As Range
Dim i As Integer
i = Worksheets("VIVA GRAPH").Range("PPTSlide")
' 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
Set PPSlide = PPPres.Slides(i)

' 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




It gives the error on Set PPSlide = PPPres.Slides(i) --> Integer out of range. 0 is not in the valid range of 1 to 4.

P.S: It is working partially, all numbers above 5 will give the abovementioned error "... valid range of 1 to 5"

JonPeltier
03-22-2016, 07:10 AM
Assuming there is a numeric value in cell B6:


Set ppSlide = ppPres.Slides(Worksheets("VIVA GRAPH").Range("B6").Value)

Djani
03-22-2016, 07:24 AM
Thanks for the help. I'm not sure if you have seen my last 'editing', but it is partially working --> all numbers above 5 will give the abovementioned error "... valid range of 1 to 5"

When the numeric value in cell B6 is 0 it gives the same error but then ".. valid range of 1 to 50"

Nevermind, I got it to work. I understand the problem --> The PPT itself had less than the number displayed in cell B6 (duhhhhh).

This is the properly working code for any of you interested:



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 rng As Range
Dim cell As Range
Dim x As Integer
x = Worksheets("VIVA GRAPH").Range("PPTSlide")
' 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
Set PPSlide = PPPres.Slides(Worksheets("VIVA GRAPH").Range("B6").Value)

' Copy chart as a picture
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
Format:=xlPicture
' Paste chart
Set newShape = PPSlide.Shapes.Paste
'Resize chart'
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




Thanks for sharing your expertise Jo(h)n, really appreciate it.

JonPeltier
03-22-2016, 07:43 AM
"... valid range of 1 to 5"
"... valid range of 1 to 50"

Where do these come from? Those are not in the error messages.

In any case, your code has to make sure the input is valid, and warn the user if it is not.

Djani
03-22-2016, 08:00 AM
It's a dumb mistake. The macro is working properly, but the presentation that was open had f.e. 4 slides in TOTAL while referring to cell B6. Any number above 4 gave this error. It was simply solved by creating additional slides in the PowerPoint itself.

I have changed the script a little bit. Instead of clicking on the chart, the user can click on a CommandButton (refers to active chart in worksheet) and automatically put the chart in the desired PPT slide. However, there can only be ONE POSSIBLE SCENARIO that will give an error like this --> if the variable (combination of country and model) is not defined. This will always give a 0 unless defined of course.

So instead of having the message "Please select a chart and try again." I was thinking of having a message "Please define combination in sheet Variable".
It's not working though!





Private Sub CommandButton2_Click()
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 rng As Range
Dim cell As Range
Dim x As Integer
x = Worksheets("VIVA GRAPH").Range("PPTSlide")
If x Is Nothing Then
MsgBox "Please define combination in sheet Variable"

Else

' Make sure a chart is selected
ActiveSheet.ChartObjects("Chart 5").Activate

' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
' Reference active slide
Set PPSlide = PPPres.Slides(Worksheets("VIVA GRAPH").Range("B6").Value)

' Copy chart as a picture
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
Format:=xlPicture
' Paste chart
Set newShape = PPSlide.Shapes.Paste
'Resize chart'
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




It gives an error at "If x Is Nothing Then".

Thanks again for sharing your expertise.

Djani
03-22-2016, 08:20 AM
Rookie mistakes, sorry for that. Changed "If x Is Nothing Then" to "If x = 0 Then" and this works perfectly fine.

JonPeltier
03-22-2016, 08:26 AM
An object variable can be Nothing, a numeric variable cannot, so the If makes no sense.

Try this modification:


Dim x As Long '' Longs are preferable to Integers
x = Worksheets("VIVA GRAPH").Range("PPTSlide").Value '' Use .Value, don't rely on default properties
If x > 0 and x < 5 Then '' explicitly set limits

Djani
03-22-2016, 08:44 AM
It's working perfect. However, I believe should also work fine:




If x = 0 Then



Yours sincerely,

Djani

JonPeltier
03-22-2016, 09:03 AM
What you said earlier indicated you need upper and lower limits.

Djani
03-22-2016, 09:26 AM
I understand, thanks again for everything. Last question. I have a properly working VBA script that removes all charts/tables in the whole presentation. However, it's missing a loop hence the reason I have to click on the macro several times to have all tables/charts removed. How can I integrate a loop in the following VBA script?




Sub DeleteAllGraphs()
Dim objApp, objSlide, ObjShp, objTable
On Error Resume Next
Set objApp = CreateObject("PowerPoint.Application")
On Error GoTo 0
For Each objSlide In objApp.ActivePresentation.Slides
For Each ObjShp In objSlide.Shapes
If ObjShp.Type = msoPicture Then ObjShp.Delete
For Each objTable In objSlide.Shapes
If objTable.Type = msoTable Then objTable.Delete
Next
Next
Next
End Sub

JonPeltier
03-22-2016, 10:09 AM
Use the same construction for all shapes. You have enough loops, too many even, since you're looking for tables within the shapes loop.


For Each ObjShp In objSlide.Shapes
If ObjShp.Type = msoPicture Then
ObjShp.Delete
ElseIf ObjShp.Type = msoTable Then
ObjShp.Delete
End If
Next