将所有图表从 Excel 工作表复制到 Powerpoint 幻灯片

Question

我已经建立了一个工作簿来帮助创建我负责的月度报告演示文稿。工作簿有一些数据表、一些处理表和编号表，其中包含我需要粘贴到相应幻灯片的图表。到目前为止，我已经构建了 VBA，用于打开 PowerPoint 模板并循环遍历每个 Excel 工作表，并区分哪些工作表名称是数字，然后激活 PowerPoint 模板上的相应幻灯片。

与我发现的类似问题的其他解决方案不同，我想一次将每个编号表中的所有图表复制到每张幻灯片，因为每张表/幻灯片的形状、数量和配置都不同。我大多只发现人们一次复制一个图表并粘贴为图像，这对我也不起作用（我需要微调数据标签和最后一张幻灯片上的位置）。关于我如何实现这一点的任何提示？

到目前为止，我的代码如下所示：

Sub CriarSlides()

Dim pptApp As Powerpoint.Application
Dim pptPres As Powerpoint.Presentation
Dim strFileToOpen As Variant
Dim strFileName As String, Hosp As String
Dim datawb As Workbook
Dim xlsCounter As Integer, xlsSlide As Integer


Set datawb = ThisWorkbook


strFileToOpen = Application.GetOpenFilename _
FileFilter:="Powerpoint Files *.pptx (*.pptx),")
If strFileToOpen = False Then
   Exit Sub
Else
   Set pptApp = New Powerpoint.Application
   pptApp.Visible = True
   pptApp.Presentations.Open Filename:=strFileToOpen, ReadOnly:=msoFalse, Untitled:=msoTrue
   Set pptPres = pptApp.Presentations(1)
End If

For xlsCounter = datawb.Worksheets.Count To 1 Step -1
    If IsNumeric(datawb.Worksheets(xlsCounter).Name) Then
       xlsSlide = datawb.Worksheets(xlsCounter).Name

' This is the problematic part

        Debug.Print xlsSlide
    End If
Next xlsCounter
End Sub

Answer 1

使用以下修改后的代码，您可以将每个工作表的图表对象粘贴到相应的幻灯片中：

Sub CriarSlides()
    Dim pptApp As PowerPoint.Application, pptPres As PowerPoint.Presentation
    Dim strFileToOpen As Variant, sh As Worksheet, ch As ChartObject

    strFileToOpen = Application.GetOpenFilename(FileFilter:="Powerpoint Files *.pptx (*.pptx),")
    If strFileToOpen = False Then Exit Sub
    Set pptApp = New PowerPoint.Application
    pptApp.Visible = True
    Set pptPres = pptApp.Presentations.Open(fileName:=strFileToOpen, ReadOnly:=msoFalse)

    For Each sh In ThisWorkbook.Sheets
        If IsNumeric(sh.name) Then
            For Each ch In sh.ChartObjects
                ch.Copy
                With pptPres.Slides(CLng(sh.name)).Shapes.Paste
                    .Top = ch.Top
                    .Left = ch.Left
                    .Width = ch.Width
                    .Height = ch.Height
                End With
            Next
        End If
    Next
End Sub