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

Question

I have built a workbook to facilitate the creation of a monthly report presentation I am in charge of. The workbook has some data sheets, some processing sheets and then numbered sheets which contain the charts I need to paste to the corresponding slide. So far, I've built the VBA for opening the PowerPoint template and looping through each excel sheet, and discriminating which sheet names are numeric, and then activating the corresponding slide on the powerpoint template.

Unlike other solutions to similar problems I've found, I'd like to copy all charts from each numbered sheet to each slide at a time, as they are different in shape, quantities and disposition for each sheet/slide. I've mostly only found people copying one chart at a time and pastying as image, which will also not work for me (I need to fine tune data labels and position on the final slide). Any hints as to how could I achieve that?

Here's what my code looks like so far:

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

With the following modified code you can paste the chart-objects of each sheet in the corresponding slide:

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