ich habe eine Liste in Excel von der ich gerne Einträge auf ein bereits vorhandenes PowerPoint sheet kopieren würden.
Es sollen die ersten 10 Einträge auf die erste Seite eingfügt werden und die Einträge 11-20 auf die nächste Seite in der selben Präsentation.
So sieht meine Firmenliste aus:
Sub PasteMultipleSlides()
'PURPOSE: Copy Excel Ranges and Paste them into the Active PowerPoint presentation slides
'SOURCE: www.TheSpreadsheetGuru.com
Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
' 'If PowerPoint is not already open then Exit
' If PowerPointApp Is Nothing Then
' MsgBox "PowerPoint Presentation is not open, aborting."
' Exit Sub
' End If
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Make PowerPoint Visible and Active
PowerPointApp.ActiveWindow.Panes(2).Activate
'Create a New Presentation
Set myPresentation = PowerPointApp.ActivePresentation
'List of PPT Slides to Paste to
MySlideArray = Array(2, 3)
'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet1.Range("A1:H28"), Sheet41.Range("A29:H53"))
'Loop through Array data
For x = LBound(MySlideArray) To UBound(MySlideArray)
'Copy Excel Range
MyRangeArray(x).Copy
'Paste to PowerPoint and position
On Error Resume Next
Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2) ' _
Excel 2007-2010
Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
On Error GoTo 0
'Center Object
With myPresentation.PageSetup
shp.Left = (.SlideWidth \ 2) - (shp.width \ 2)
shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
End With
Next x
'Transfer Complete
Application.CutCopyMode = False
ThisWorkbook.Activate
MsgBox "Complete!"
End Sub
Mit diesem Code habe ich es probiert aber selbst mit einer statischen Auswahl habe ich es nicht hinbekommen.
Mit der Count funktion bei der Range leider auch nicht.
Ich freue mich auf eure Antworten!