将所有图表从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