Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Einträge einer Excel Tabelle zu PowerPoint kopiere


Betrifft: Einträge einer Excel Tabelle zu PowerPoint kopiere von: Marion
Geschrieben am: 11.01.2018 17:31:13

Hallo,
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!

  

Betrifft: AW: Einträge einer Excel Tabelle zu PowerPoint kopiere von: Dieter Klemke
Geschrieben am: 12.01.2018 22:04:53

Hallo Marion,
du kannst das mit dem folgenden Programm machen.
Das Programm legt eine neue Präsention mit 2 Folien an unter dem Namen "NeuePräsentation.pptx" und in dem Verzeichnis, aus dem die Excel-Arbeitsmappe geladen wurde.

Sub PowerPoint_Präsentation_erzeugen()
  Dim anzTexte As Long
  Dim anzZeilen As Long
  Dim i As Long
  Dim oben As Single
  Dim ppt As Object
  Dim Pfad As String
  Dim ppApp As Object
  Dim rng As Range
  Dim shr As Object
  Dim sl As Object
  Dim ws As Worksheet
  Dim zeile As Long
  
  Set ppApp = CreateObject("PowerPoint.Application")
  ppApp.Visible = True
  Set ppt = ppApp.Presentations.Add
  zeile = 1
  For i = 1 To 2
    Set sl = ppt.Slides.Add(Index:=i, _
                            Layout:=12)  ' ppLayoutBlank = 12
    Pfad = ThisWorkbook.Path
    ppt.SaveAs _
         Filename:=Pfad & "\NeuePräsentation.pptx"
    oben = 20
    anzTexte = 0
    Set ws = ThisWorkbook.Worksheets("Liste")
    Do Until anzTexte = 10
      Set rng = ws.Cells(zeile, "A").MergeArea
      anzZeilen = rng.Rows.Count
      Set rng = ws.Cells(zeile, "A").Resize(anzZeilen, 8)
      zeile = zeile + anzZeilen
      rng.CopyPicture
      Set shr = sl.Shapes.Paste
      shr.Top = oben
      shr.Left = 30
      oben = oben + shr.Height + 3
      anzTexte = anzTexte + 1
    Loop
  Next i
  ppt.Save
  ppt.Close
  ' PowerPoint beenden
  ppApp.Quit
  Set ppApp = Nothing
End Sub

https://www.herber.de/bbs/user/118911.xlsm

mfg
Dieter


Beiträge aus dem Excel-Forum zum Thema "Einträge einer Excel Tabelle zu PowerPoint kopiere"