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

我已经build立了一本工作手册，以方便创build我负责的月度报告。 工作簿有一些数据表，一些处理表，然后编号表，其中包含我需要粘贴到相应的幻灯片的图表。 到目前为止，我已经构build了用于打开PowerPoint模板并遍历每个Excel表格的VBA，并区分哪些表格名称是数字的，然后在PowerPoint模板上激活相应的幻灯片。

与我发现的其他类似问题的解决scheme不同，我希望一次将每张编号表中的所有图表复制到每张幻灯片，因为它们在形状，数量和每张幻灯片的处理方面都不相同。 大多数情况下，我发现人们一次只复制一张图表，然后以图像的forms进行粘贴，这对我也不起作用（我需要对数据标签进行微调，并在最后一张幻灯片上进行定位）。 任何暗示，我怎么能实现呢？

以下是我的代码到目前为止：

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