Here is a function which will export excel range, chart, shape or print area to Power point
Add new module and copy below code
Option Explicit 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) 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 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") End Sub 'Here is how we can use it Sub PrintAreaToPPT() 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.ActivePresentation.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