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