Vba 将指定的图表选择作为图像导出到不同的.ppt幻灯片

我试图做的是将选定的图表作为图像导出到不同的PowerPoint幻灯片中。当我尝试导出一个图表时，它是有效的，但是选择多个图表并尝试再次导出它们是无效的

我错过了什么？ 下面是我迄今为止试图解决我的问题的代码

Sub SendTop2ChartsToPPT()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim pptShpRng As PowerPoint.ShapeRange
Dim lActiveSlideNo As Long
Dim ChtObj As ChartObject
Dim ChartSh As Worksheet
Dim FolderPath As String
Dim fName As String

Set ChartSh = Worksheets("Graphs")
FolderPath = ThisWorkbook.Path
fName = "Report Top2 (" & Format(Date, "yyyy-mmm") & ")"
On Error Resume Next
Set pptApp = GetObject(, "PowerPoint.Application")
On Error Resume Next
If pptApp Is Nothing Then
    Set pptApp = CreateObject("PowerPoint.Application")
    Set pptPres = pptApp.Presentations.Add
    Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
Else
    If pptApp.Presentations.Count > 0 Then
        Set pptPres = pptApp.ActivePresentation
        If pptPres.Slides.Count > 0 Then
            lActiveSlideNo = pptApp.ActiveWindow.View.Slide.SlideIndex
            Set pptSlide = pptPres.Slides(lActiveSlideNo)
        Else
            Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
        End If
    Else
        Set pptPres = pptApp.Presentations.Add
        Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
    End If
End If
ChartSh.Shapes.Range(Array("Top2SiteVisits", "Top2SiteShare")).Select
Set ChtObj = Selection.ShapeRange.Group
ChtObj.CopyPicture

    With pptSlide
        .Shapes.Paste
        Set pptShape = .Shapes(.Shapes.Count)
        Set pptShpRng = .Shapes.Range(pptShape.Name)
    End With

    With pptShpRng
        .Top = 0
        .Left = 0
        .Height = pptPres.PageSetup.SlideHeight
        .Width = pptPres.PageSetup.SlideWidth
    End With

    With pptPres
        .SaveAs FolderPath & "\" & fName & ".pptx"
        .Close
    End With

    pptApp.Quit
    ChtObj.ShapeRange.Ungroup
    Set pptSlide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
End Sub

---

脚本的powerpoint部分很好，可以使用

说到图表，我建议不要处理形状，而只是使用

ChartObjects

集合-

ChartObject

是在工作表上保存实际

图表的容器

我不完全确定你所说的“选择”要发送到ppt的图表是什么意思，以及你为什么要处理
shaperage
数组和处理形状组等等，但假设你在一张纸上有一堆图表，您选择了一些图表，并希望将它们复制粘贴到powerpoint中作为图片：下面的操作就是这样做的，每个图表都有一张新幻灯片

Sub SelectedChartsToPPTSlide()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim ChtObj As ChartObject

Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add

For Each ChtObj In Selection 'Will error if your selection includes other shapes and such.
    Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
    ChtObj.Chart.CopyPicture
    pptSlide.Shapes.PasteSpecial
Next ChtObj

Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
End Sub

同样，您可以在工作表中循环查看
图表对象
：

For each ChtObj in Worksheets("Graphs").ChartObjects
    If ChtObj.Chart.Name = "Some name here" Then
        'Do stuff with that chart
    End If
Next ChtObj

希望这有帮助

注意：如果您需要操作powerpoint幻灯片上的图片，可以使用
Set-pastedPictureShape=pptSlide.Shapes（pptSlide.Shapes.Count）
在
PasteSpecial