Sub Copy_Paste_to_PowerPoint()
Dim ppApp As PowerPoint.Application
Dim ppSlide As PowerPoint.Slide
Dim SheetName As String
Dim TestRange As Range
Dim TestSheet As Worksheet
Dim TestChart As ChartObject
Dim PasteChart As Boolean
Dim PasteChartLink As Boolean
Dim ChartNumber As Long
Dim PasteRange As Boolean
Dim RangePasteType As String
Dim RangeName As String
Dim AddSlidesToEnd As Boolean
SheetName = ActiveSheet.Name
PasteRange = True
RangeName = "MyRange"
RangePasteType = "HTML"
RangeLink = True
PasteChart = True
PasteChartLink = True
ChartNumber = 1
AddSlidesToEnd = True
On Error Resume Next
Set TestSheet = Sheets(SheetName)
Set TestRange = Sheets(SheetName).Range(RangeName)
Set TestChart = Sheets(SheetName).ChartObjects(ChartNumber)
On Error GoTo 0
If TestSheet Is Nothing Then
MsgBox "Sheet " & SheetName & " does not exist. Macro will exit", vbCritical
Exit Sub
End If
If PasteRange And TestRange Is Nothing Then
MsgBox "Range " & RangeName & " does not exist. Macro will exit", vbCritical
Exit Sub
End If
If PasteRange = False And PasteChart And TestChart Is Nothing Then
MsgBox "Chart " & ChartNumber & " does not exist. Macro will exit", vbCritical
Exit Sub
End If
On Error Resume Next
Set ppApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If ppApp Is Nothing Then Set ppApp = New PowerPoint.Application
If ppApp.Presentations.Count = 0 Then ppApp.Presentations.Add
ppApp.Visible = True
If ppApp.ActivePresentation.Slides.Count = 0 Then
Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
Else
If AddSlidesToEnd Then
ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank
ppApp.ActiveWindow.View.GotoSlide ppApp.ActivePresentation.Slides.Count
Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresentation.Slides.Count)
Else
Set ppSlide = ppApp.ActiveWindow.View.Slide
End If
End If
If PasteRange = True Then
If RangePasteType = "Picture" Then
Worksheets(SheetName).Range(RangeName).Copy
ppSlide.Shapes.PasteSpecial(ppPasteDefault, link:=RangeLink).Select
Else
Worksheets(SheetName).Range(RangeName).Copy
ppSlide.Shapes.PasteSpecial(ppPasteHTML, link:=RangeLink).Select
End If
Else
Worksheets(SheetName).Activate
ActiveSheet.ChartObjects(ChartNumber).Select
If PasteChartLink = True Then
ActiveChart.ChartArea.Copy
ppSlide.Shapes.PasteSpecial(link:=True).Select
Else
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
ppSlide.Shapes.Paste.Select
End If
End If
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
AppActivate ("Microsoft PowerPoint")
Set ppSlide = Nothing
Set ppApp = Nothing
End Sub
|