Copy/Paste Excel Range/Chart into Powerpoint VBA

[Admin]

Hi All,

Here is a routine which helps you to copy paste a range or chart into power point.

Copy the entire code and paste into a new Standard module.


Public Enum PasteFormat
xl_Link = 0
xl_HTML = 1
xl_Bitmap = 2
End Enum

Sub Copy_Paste_to_PowerPoint(ByRef ppApp As Object, ByRef ppSlide As Object, ByVal ObjectSheet As Worksheet, _
ByRef PasteObject As Object, Optional ByVal Paste_Type As PasteFormat)

' Modified version of code originally posted here:
' http://www.vbaexpress.com/kb/getarticle.php?kb_id=370

' Modified by : Krishnakumar @ ExcelFox.com
' Used Late binding so that no issues when users have multiple Excel version

Dim PasteRange As Boolean
Dim objChart As ChartObject
Dim lngSU As Long

Select Case TypeName(PasteObject)
Case "Range"
If Not TypeName(Selection) = "Range" Then Application.Goto PasteObject.Cells(1)
PasteRange = True
Case "Chart": Set objChart = PasteObject.Parent
Case "ChartObject": Set objChart = PasteObject
Case Else
MsgBox PasteObject.Name & " is not a valid object to paste. Macro will exit", vbCritical
Exit Sub
End Select

With Application
lngSU = .ScreenUpdating
.ScreenUpdating = 0
End With

ppApp.ActiveWindow.View.GotoSlide ppSlide.slidenumber

On Error GoTo -1: On Error GoTo 0
DoEvents

If PasteRange Then
If Paste_Type = xl_Bitmap Then
'//Paste Range as Picture
PasteObject.CopyPicture Appearance:=1, Format:=-4147
ppSlide.Shapes.Paste.Select
ElseIf Paste_Type = xl_HTML Then
'//Paste Range as HTML
PasteObject.Copy
ppSlide.Shapes.PasteSpecial(8, link:=1).Select 'ppPasteHTML
ElseIf Paste_Type = xl_Link Then
'//Paste Range as Linked
PasteObject.Copy
ppSlide.Shapes.PasteSpecial(0, link:=1).Select 'ppPasteDefault
End If
Else
If Paste_Type = xl_Link Then
'//Copy & Paste Chart Linked
objChart.Chart.ChartArea.Copy
ppSlide.Shapes.PasteSpecial(link:=True).Select
Else
'//Copy & Paste Chart Not Linked
objChart.Chart.CopyPicture Appearance:=1, Size:=1, Format:=2
ppSlide.Shapes.Paste.Select
End If
End If

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

With Application
.CutCopyMode = False
.ScreenUpdating = lngSU
End With

AppActivate ("Microsoft Excel")

End Sub




An example sub to call the routine



Sub kTest()

Dim ppApp As Object
Dim ppSlide As Object

On Error Resume Next
Set ppApp = GetObject(, "Powerpoint.Application")
On Error GoTo 0

If ppApp Is Nothing Then
Set ppApp = CreateObject("Powerpoint.Application")
ppApp.Visible = True
ppApp.presentations.Add
End If

If ppApp.ActivePresentation.Slides.Count = 0 Then
Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, 12) 'ppLayoutBlank
Else
ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, 12
Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresen tation.Slides.Count)
End If

'//or you could specify the slide number. e.g. for the second slide
'Set ppSlide = ppApp.ActivePresentation.Slides(2)

Copy_Paste_to_PowerPoint ppApp, ppSlide, Sheet1, Sheet1.ChartObjects(1).Chart, xl_Bitmap

'//Range

'Copy_Paste_to_PowerPoint ppApp, ppSlide, Sheet1, Sheet1.Range("A1:J6"), xl_Bitmap

End Sub

[LalitPandey87]

Revised routine, with excel image adjustment in powerpoint slide.



Public Enum PasteFormat
xl_Link = 0
xl_HTML = 1
xl_Bitmap = 2
End Enum

Sub Copy_Paste_to_PowerPoint(ByRef ppApp As Object, ByRef ppSlide As Object, ByRef PasteObject As Object, Optional ByVal Paste_Type As PasteFormat)

' Modified by : LalitMohan @ ExcelFox.com


Dim PasteRange As Boolean
Dim objChart As ChartObject


Select Case TypeName(PasteObject)
Case "Range"
If Not TypeName(Selection) = "Range" Then Application.Goto PasteObject.Cells(1)
PasteRange = True
Case "Chart": Set objChart = PasteObject.Parent
Case "ChartObject": Set objChart = PasteObject
Case Else
MsgBox PasteObject.Name & " is not a valid object to paste. Macro will exit", vbCritical
Exit Sub
End Select

ppApp.ActiveWindow.View.GotoSlide ppSlide.slidenumber

On Error GoTo -1: On Error GoTo 0
DoEvents

If PasteRange Then
If Paste_Type = xl_Bitmap Then
'//Paste Range as Picture
PasteObject.CopyPicture Appearance:=1, Format:=-4147
ppSlide.Shapes.Paste.Select
ElseIf Paste_Type = xl_HTML Then
'//Paste Range as HTML
PasteObject.Copy
ppSlide.Shapes.PasteSpecial(8, link:=1).Select 'ppPasteHTML
ElseIf Paste_Type = xl_Link Then
'//Paste Range as Linked
PasteObject.Copy
ppSlide.Shapes.PasteSpecial(0, link:=1).Select 'ppPasteDefault
End If
Else
If Paste_Type = xl_Link Then
'//Copy & Paste Chart Linked
objChart.Chart.ChartArea.Copy
ppSlide.Shapes.PasteSpecial(link:=True).Select
Else
'//Copy & Paste Chart Not Linked
objChart.Chart.CopyPicture Appearance:=1, Size:=1, Format:=2
ppSlide.Shapes.Paste.Select
End If
End If

'//Center pasted object in the slide
With ppApp.ActiveWindow.Selection.ShapeRange
.LockAspectRatio = False
.Height = ppSlide.Parent.PageSetup.SlideHeight * 0.98
.LockAspectRatio = False
.Width = ppSlide.Parent.PageSetup.SlideWidth * 0.98
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
End With

Call AppActivate("Microsoft Excel")

PasteRange = Empty
Set objChart = Nothing

End Sub



Example sub to call this routine



Sub LalitTest()

Dim ppApp As Object
Dim ppSlide As Object

Application.ScreenUpdating = False
On Error Resume Next
Set ppApp = GetObject(, "Powerpoint.Application")
On Error GoTo -1: On Error GoTo 0: Err.Clear

If ppApp Is Nothing Then
Set ppApp = CreateObject("Powerpoint.Application")
ppApp.Visible = True
ppApp.presentations.Add
End If

If ppApp.ActivePresentation.Slides.Count = 0 Then
Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, 12) 'ppLayoutBlank
Else
ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, 12
Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresen tation.Slides.Count)
End If

Call Copy_Paste_to_PowerPoint(ppApp, ppSlide, ActiveSheet.Range("Print_Area"), xl_Bitmap)

Application.ScreenUpdating = True

Set ppApp = Nothing
Set ppSlide = Nothing

End Sub