Domine o Excel ® (3 em 1): Excel - 70 Fórmulas Incríveis, Excel - 51 Macros incríveis e 51 Dicas e Truques Incríveis

Sub Selection_to_PowerPoint()
Dim iRange As Range
Dim PptObj As Object
Dim iPresent As Object
Dim iSlide As Object
Dim iShape As Object
Set iRange = Selection
On Error Resume Next
Set PptObj = GetObject(class:="PowerPoint.Application")
Err.Clear
If PptObj Is Nothing Then Set PptObj =
CreateObject(class:="PowerPoint.Application")
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
Application.ScreenUpdating = False
Set iPresent = PptObj.Presentations.Add
Set iSlide = iPresent.Slides.Add(1, 11)
iRange.Copy
iSlide.Shapes.PasteSpecial DataType:=2
Set iShape = iSlide.Shapes(iSlide.Shapes.Count)
iShape.Left = 100
iShape.Top = 160
PptObj.Visible = True
PptObj.Activate