Option Explicit
'Both subs require a reference to Microsoft PowerPoint xx.x Object Library.
'where xx.x is your office version (11.0 = 2003, 12.0 = 2007 and 14.0 = 2010).
'Declaring the necessary Power Point variables, whick are used in both subs.
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlideCount As Integer
Sub TablesToPowerPoint()
Dim cl As Range
'Open Power Point and create a new presentation.
Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add
'Show the Power Point application.
pptApp.Visible = True
'Loop through tables of ranges
Application.ScreenUpdating = False
For Each cl In Worksheets("Home").Range("rngPrintRanges")
Call ExcelTableToPowerPoint(cl.Value, cl.Offset(0, 1).Value)
Next cl
Application.ScreenUpdating = True
'Inform the user that the macro finished.
MsgBox "The ranges were successfully copied to the new presentation!", vbInformation, "Done"
End Sub
Private Sub ExcelTableToPowerPoint(xlSheet As String, xlRange As String)
Dim pptSlide As PowerPoint.Slide
'Check if the range is valid.
With Worksheets(xlSheet)
If Application.Intersect(.Range(xlRange), .Cells) Is Nothing Then
MsgBox "Sorry, the range you selected is not valid!", vbCritical, "Invalid range"
Exit Sub
End If
'Count the slides and add a new one after the last slide.
pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
'Copy the range and paste as image
.Range(xlRange).Copy
pptSlide.Shapes.PasteSpecial (ppPasteMetafilePicture)
End With
End Sub