Copy each excel worksheets and paste in each indivual slides

[Ken Puls]

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.

[Shazam]

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

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.