VBA:Excel到Powerpoint的副本+；将选定图表粘贴到活动PPT幻灯片中

我希望将Excel中选定的图表复制并粘贴到活动的PPT幻灯片中。我有一个代码，可以创建一个新工作簿并粘贴工作簿中的所有图表，但希望将该命令仅限于选定的图表。代码如下：

Option Explicit
Sub CopyChartsToPowerPoint()

'Excel Application objects declaration
Dim ws As Worksheet
Dim objChartObject As ChartObject
Dim objChart As Chart
Dim objCht As Chart
Dim lngSlideKount As Long

'Powerpoint Application objects declaration
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide

'Create a new Powerpoint session
Set pptApp = CreateObject("PowerPoint.Application")

pptApp.Visible = msoTrue
'Create a new presentation
Set pptPres = pptApp.Presentations.Add
Set pptPres = pptApp.ActivePresentation

pptApp.ActiveWindow.ViewType = ppViewSlide

lngSlideKount = 0
For Each ws In ActiveWorkbook.Worksheets
  'Verify if there is a chart object to transfer
  If ws.ChartObjects.Count > 0 Then
    For Each objChartObject In ws.ChartObjects
        Set objChart = objChartObject.Chart
        'ppLayoutBlank = 12
        Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
        pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex

    With objChart
        'Copy + paste chart object as picture
        objChart.CopyPicture xlScreen, xlBitmap, xlScreen
        pptSld.Shapes.Paste.Select
        'Coordinates will change depending on chart
        With pptApp.ActiveWindow.Selection.ShapeRange
            .Left = 456
            .Top = 20
        End With
    End With

      lngSlideKount = lngSlideKount + 1
    Next objChartObject
  End If
Next ws

' Now check CHART sheets:
For Each objCht In ActiveWorkbook.Charts
    'ppLayoutBlank = 12
    Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
    pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
    With objCht
        'Copy chart object as picture
        .CopyPicture xlScreen, xlBitmap, xlScreen
        'Paste copied chart picture into new slide
        pptSld.Shapes.Paste.Select
        pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
        pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
    End With
    lngSlideKount = lngSlideKount + 1
Next objCht
'
'Activate PowerPoint application
pptApp.ActiveWindow.ViewType = ppViewNormal
pptApp.Visible = True
pptApp.Activate
If lngSlideKount > 0 Then
    If lngSlideKount = 1 Then
        MsgBox "1 chart was copied to PowerPoint", vbOKOnly + vbInformation, "Information"
    Else
        MsgBox lngSlideKount & " charts were copied to PowerPoint", vbOKOnly + vbInformation, "Information"
    End If
End If


End Sub

---

感谢大家的帮助

Excel for Charts中似乎没有一个很好的easy.IsSelected属性，因此您需要在此函数中分析所选内容，您可以从过程中调用该函数来获取所选图表的集合（在处理集合中的每个项目之前进行测试以确保它不是空的）：

---

这是一个对我有效的解决方案。宏复制+将选定范围或图表粘贴到活动PowerPoint幻灯片中的特定位置。我之所以想这样做，是因为我们每个季度/每月都会为客户生成报告，这有助于减少复制+粘贴和使平台看起来美观所需的时间。希望这能帮助其他制作大量PPT的人

'Export and position into Active Powerpoint

'Prior to running macro, enable Microsoft Powerpoint Object Library in Tools - Reference

'Identifies selection as either range or chart
Sub ButtonToPresentation()

If TypeName(Selection) = "Range" Then
    Call RangeToPresentation
Else
    Call ChartToPresentation
End If

End Sub

Sub RangeToPresentation()

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide

'Error message if range is not selected
If Not TypeName(Selection) = "Range" Then
    MsgBox "Please select a worksheet range and try again."
Else
    'Reference existing instance of PowerPoint
    Set PPApp = GetObject(, "Powerpoint.Application")
    'Reference active presentation
    Set PPPres = PPApp.ActivePresentation
    'Reference active slide
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

    'Copy the range as a picture
    Selection.CopyPicture Appearance:=xlScreen, _
    Format:=xlBitmap
    'Paste the range
    PPSlide.Shapes.Paste.Select

    'Align the pasted range
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing
End If

End Sub

Sub ChartToPresentation()
'Uses Late Binding to the PowerPoint Object Model
'No reference required to PowerPoint Object Library

Dim PPApp As Object 'As PowerPoint.Application
Dim PPPres As Object 'As PowerPoint.Presentation
Dim PPSlide As Object 'As PowerPoint.Slide

'Error message if chart is not selected
If ActiveChart Is Nothing Then
    MsgBox "Please select a chart and try again."
Else
    'Reference existing instance of PowerPoint
    Set PPApp = GetObject(, "Powerpoint.Application")
    'Reference active presentation
    Set PPPres = PPApp.ActivePresentation
   'PPApp.ActiveWindow.ViewType = 1 ' 1 = ppViewSlide
    'Reference active slide
    Set PPSlide = PPPres.Slides _
        (PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

    'Copy chart as a picture
    ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
        Format:=xlPicture
    'Paste chart
    PPSlide.Shapes.Paste.Select

    'Align pasted chart
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing
End If

End Sub

---

的答案将向您展示如何仅使用选定的图表。。。如果在工作表中选择了一个或多个图表，则此功能将起作用。如果需要，可以循环浏览多个工作表。如果选中图表区域旁边的元素，该怎么办？执行

如果不是活动图表，则执行
首先执行活动图表，然后执行
ElseIf TypeName（Selection）=“DrawingObjects”，然后执行
在选定形状中循环并执行图表。
'Export and position into Active Powerpoint

'Prior to running macro, enable Microsoft Powerpoint Object Library in Tools - Reference

'Identifies selection as either range or chart
Sub ButtonToPresentation()

If TypeName(Selection) = "Range" Then
    Call RangeToPresentation
Else
    Call ChartToPresentation
End If

End Sub

Sub RangeToPresentation()

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide

'Error message if range is not selected
If Not TypeName(Selection) = "Range" Then
    MsgBox "Please select a worksheet range and try again."
Else
    'Reference existing instance of PowerPoint
    Set PPApp = GetObject(, "Powerpoint.Application")
    'Reference active presentation
    Set PPPres = PPApp.ActivePresentation
    'Reference active slide
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

    'Copy the range as a picture
    Selection.CopyPicture Appearance:=xlScreen, _
    Format:=xlBitmap
    'Paste the range
    PPSlide.Shapes.Paste.Select

    'Align the pasted range
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing
End If

End Sub

Sub ChartToPresentation()
'Uses Late Binding to the PowerPoint Object Model
'No reference required to PowerPoint Object Library

Dim PPApp As Object 'As PowerPoint.Application
Dim PPPres As Object 'As PowerPoint.Presentation
Dim PPSlide As Object 'As PowerPoint.Slide

'Error message if chart is not selected
If ActiveChart Is Nothing Then
    MsgBox "Please select a chart and try again."
Else
    'Reference existing instance of PowerPoint
    Set PPApp = GetObject(, "Powerpoint.Application")
    'Reference active presentation
    Set PPPres = PPApp.ActivePresentation
   'PPApp.ActiveWindow.ViewType = 1 ' 1 = ppViewSlide
    'Reference active slide
    Set PPSlide = PPPres.Slides _
        (PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

    'Copy chart as a picture
    ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
        Format:=xlPicture
    'Paste chart
    PPSlide.Shapes.Paste.Select

    'Align pasted chart
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing
End If

End Sub