Hallo Zusammen,

ich möchte gerne mehrere Excel-Diagramme aus separaten Tabellenblätter über ein Makro in eine vorhandene PowerPoint Vorlage exportieren. Die Diagramme sollen in diese nacheinander ab Folie 3 eingefügt werden. Im Moment werden durch meinen Code alle Diagramme in Folie 3 eingefügt. Was muss ich ändern bzw. hinzufügen, damit ab Folie 3 immer eine neue Folie hinzugefügt wird und die Diagramme dort reinkopiert werden?
Ich bin absoluter VBA Neuling, bin also über jede Hilfe und Tipps dankbar.
Vielen Dank im Voraus!

Sub AllChartsToPowerPoint()
    Dim ppApp As PowerPoint.Application
    Dim xlChart As Excel.Chart
    'Dim xlChartEmbedded As Excel.ChartObject
    
    Dim xlWB As New Excel.Workbook
    Dim intWB As Integer
    Dim intCtWBs As Integer
    
    Dim intChart As Integer
    'Dim intChartEmbedded As Chart
    
    'In separaten Blättern dargestellte Grafiken
    Dim intCtCharts As Integer
    
    'In Tabellen eingebettete Grafiken
    'Dim intCtChtsEmbedded As Integer
    
    'Geöffnete Arbeitsmappen zählen
    intCtWBs = Workbooks.Count
    
    'PowerPoint-Objekt initialisieren
    Set ppApp = New PowerPoint.Application
    
    With ppApp
        .Visible = True
        .Activate
        .Presentations.Open ("\\emea.baumernet.org\de01d\Templates\All\B_PPT_Confidential_ONLY_internal_use.potx")
        
        For intWB = 1 To intCtWBs
        
            'Grafiken in separaten Blättern zählen
            intCtCharts = Workbooks(intWB).Charts.Count
            
                For intChart = 1 To intCtCharts
                
                    Set xlChart = Workbooks(intWB).Charts(intChart)
                    
                    xlChart.ChartArea.Copy
                    
                    With .ActivePresentation
                        '.Slides.Add 1, ppLayoutBlank
                        .Slides(3).Shapes.PasteSpecial ppPasteBitmap
                        
                        With .Slides(3).Shapes.Range
                            .Height = 300
                            .Width = 600
                            .Left = 60
                            .Top = 85
                        End With
                    End With
                Next
            Next
        End With
        
        'PowerPoint-Objekt aus dem Speicher entfernen
        Set ppApp = Nothing
        
End Sub