Export Excel Area to PowerPoint

Here are some things which could help but I can't get it to work. The quality of the image is mucht better than the code in the attached file.

Option Explicit

Dim PP As Object
Dim PP_File As Object
Dim PP_Slide As Object

Private Sub CopyandPastetoPPT(myRangeName As String, myTitle As String, myScaleHeight As Single, myScaleWidth As Single)
Dim NextShape As Integer
Dim ReportDate As String

ReportDate = Range("Headline1").value & "" & Range("Headline2").value & ""
Application.GoTo Reference:=myRangeName
Selection.CopyPicture Appearance:=xlScreen, format:=xlPicture
Range("A1").Select
PP.ActivePresentation.Slides.Add PP.ActivePresentation.Slides.Count + 1, 11
Set PP_Slide = PP_File.Slides(PP.ActivePresentation.Slides.Count)
PP_Slide.Shapes.Title.TextFrame.TextRange.text = ReportDate & myTitle
NextShape = PP_Slide.Shapes.Count + 1
PP_Slide.Shapes.PasteSpecial 2
PP_Slide.Shapes(NextShape).ScaleHeight myScaleHeight, 2
PP_Slide.Shapes(NextShape).ScaleWidth myScaleWidth, 1
PP_Slide.Shapes(NextShape).Left = PP_File.PageSetup.SlideWidth \ 2.5 - PP_Slide.Shapes(NextShape).Width \ 2
PP_Slide.Shapes(NextShape).Top = 65

End Sub

Sub ExportToPPT()
Dim ActFileName As Variant
Dim ScaleFactor As Single

On Error GoTo ErrorHandling
ActFileName = Application.GetOpenFilename("Microsoft PowerPoint-Files (*.pptx), *.pptx")
ScaleFactor = Range("myScaleFactor").value
Set PP = CreateObject("Powerpoint.Application")
If ActFileName = False Then
PP.Activate
PP.Presentations.Add
Set PP_File = PP.ActivePresentation
Else
PP.Activate
Set PP_File = PP.Presentations.Open(ActFileName)
End If
PP.Visible = True
CopyandPastetoPPT "Area01", Range("myInputStartTitles").Offset(1, 0).value, ScaleFactor, ScaleFactor
' CopyandPastetoPPT "Area02", Range("myInputStartTitles").Offset(2, 0).Value, ScaleFactor, ScaleFactor
' CopyandPastetoPPT "Area03", Range("myInputStartTitles").Offset(3, 0).Value, ScaleFactor, ScaleFactor
' CopyandPastetoPPT "Area04", Range("myInputStartTitles").Offset(4, 0).Value, ScaleFactor, ScaleFactor
' CopyandPastetoPPT "Area05", Range("myInputStartTitles").Offset(5, 0).Value, ScaleFactor, ScaleFactor
Set PP_Slide = Nothing
Set PP_File = Nothing
Set PP = Nothing

Exit Sub

ErrorHandling:

Set PP_Slide = Nothing
Set PP_File = Nothing
Set PP = Nothing
MsgBox "Error No.: " & Err.number & vbNewLine & vbNewLine & "Description: " & Err.Description, vbCritical, "Error"

End Sub

Hi all,

do you think the idea is not worth your time or is there something similar out there?
I would really appreciate your help

Thank you,
bris