Copy each excel worksheets and paste in each indivual slides

Here is the link I ask the question the first time.

http://vbaexpress.com/forum/showthre...9284#post59284


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

Code:

---

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.

Code:

---


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

---

Hi Shazam,

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

[vba]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[/vba]

HTH,

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.

Code:

---


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

---

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:

[vba]set pptShp = pptSld.Shapes.Add
With pptShp
.Left = 10
.Right = 100
End With[/vba]

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,

No prolblem Ken Puls I'll wait.

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. :)

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

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

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

Code:

---


 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

---

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.

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:
[VBA] ' 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
[/VBA]

Jon thanks for your help, I did a workaround and I like it.

Thanks

Mike in wisconsin

Hi Jon

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

Quote:

---

Originally Posted by JonPeltier

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:
[vba] ' 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
[/vba]

---

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:

[VBA]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[/VBA]

or simply copy the used range:

[VBA] ObjSheet.UsedRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
[/VBA]

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

Quote:

---

Originally Posted by JonPeltier

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:

[VBA]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[/VBA]

or simply copy the used range:

[VBA] ObjSheet.UsedRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
[/VBA]

---

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

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?

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.
Attachment 15624Yours sincerely,

Djani

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.

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
Attachment 15625

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

Many thanks