Copy each excel worksheets and paste in each indivual slides

[JonPeltier]

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]

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]

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]

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]

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]

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]

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]

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.

table.jpg

Yours sincerely,

Djani Sadloe

[JonPeltier]

... 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]

... 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]

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]

... 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]

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]

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]

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]

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]

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]

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]

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]

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