Excel: Copy Range/Chart to PowerPoint

'**************************************************************************
' Copy Excel Range/Chart to PowerPoint
' This macro copies a range/chart from Excel to PowerPoint.
' 1. PowerPoint presentation should be opened for the macro to work properly
' 2. Macro asks for user input whether to copy a range or chart
' 3. Then asks whether to paste as Link as picture or link
' 4. It also makes sure the chart/range fits into PowerPoint slide by adjusting
' the height and width of pasted object.
'**************************************************************************
Sub Copy_Paste_to_PowerPoint()
'Requires a reference to the Microsoft PowerPoint Library via the Tools - Reference menu in the VBE
Dim ppApp As PowerPoint.Application
Dim ppSlide As PowerPoint.Slide

Dim msg As String
Dim temp As Variant

Dim PasteChart As Boolean
Dim PasteChartLink As Boolean

Dim lHeight As Long
Dim lWidth As Long

'Look for existing instance of PowerPoint
On Error Resume Next
Set ppApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0

'Sets current slide to active slide
Set ppSlide = ppApp.ActiveWindow.View.Slide

'Copy Range/Chart?
temp = MsgBox("Do you want to Copy-Paste Chart or Range? Yes=Chart ; No=Range", vbYesNo)
If temp = 6 Then
PasteChart = True
Else
PasteChart = False
End If

'Pasting a Chart
If PasteChart = True Then
Select Case TypeName(Selection)
'Paste Chart/Charts
Case "Chart", "ChartArea"
'Paste Chart as picture/link?
temp = MsgBox("Paste chart as a picture? Yes=Picture ; No=Link", vbYesNo)
If temp = 7 Then
PasteChartLink = True
Else
PasteChartLink = False
End If
'Copy Paste action
If PasteChartLink = True Then
'Copy & Paste Chart Linked
'ActiveChart.ChartArea.Copy
Selection.Copy
ppSlide.Shapes.PasteSpecial(link:=True).Select
Else
'Copy & Paste Chart Not Linked
'ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
'ppSlide.Shapes.Paste.Select
Selection.Copy
ppSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Select
End If
'Paste DrawingObjects (Multiple charts/drawing objects)
Case "DrawingObjects"
Selection.Copy
ppSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Select
Case Else
msg = MsgBox("Select a Chart and run macro", vbOKOnly, "Select a Chart")
'End Sub
End Select
'Pasting a Range
Else
'Paste Chart as picture/link?
temp = MsgBox("Paste Range as a picture? Yes=Picture ; No=Link", vbYesNo)
If temp = 7 Then
PasteRangeLink = False
Else
PasteRangeLink = True
End If
'Options for Copy & Paste Ranges
If RangePasteType = True Then
'Paste Range as Picture
'Worksheets(SheetName).Range(RangeName).Copy
Selection.Copy
ppSlide.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
Else
'Paste Range as Picture Link
'Worksheets(SheetName).Range(RangeName).Copy
Selection.Copy
ppSlide.Shapes.PasteSpecial(ppPasteMetafilePicture, link:=msoTrue).Select
End If
End If


' Get the slide height and width.
lHeight = ppApp.ActivePresentation.PageSetup.SlideHeight
lWidth = ppApp.ActivePresentation.PageSetup.SlideWidth

' Set Height & Width of pasted object to fit the slide
If ppApp.ActiveWindow.Selection.ShapeRange.Height > lHeight Then
ppApp.ActiveWindow.Selection.ShapeRange.Height = lHeight
End If
If ppApp.ActiveWindow.Selection.ShapeRange.Width > lWidth Then
ppApp.ActiveWindow.Selection.ShapeRange.Width = lWidth
End If

' Center pasted object in the slide
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

' Activate PowerPoint window
AppActivate ("Microsoft PowerPoint")
Set ppSlide = Nothing
Set ppApp = Nothing

End Sub