VBA: Excel-Inhalt in Powerpoint einfügen. Fehlermeldung: Zwischenablage ist leer oder enthält Daten, die hier möglicherweise nicht eingefügt werden

Question

Ich versuche, einige Daten von meinem Excel-Blatt zu schneiden und es als Bild in einer Präsentation einzufügen. Oft wird jedoch eine Fehlermeldung angezeigt: Shapes (unbekanntes Mitglied): ungültige Anfrage. Die Zwischenablage ist leer oder enthält Daten, die hier nicht eingefügt werden können. Manchmal scheint es früher manchmal später, manchmal funktioniert es auch und alle Folien erstellt bekommen .. Mein Code ist der folgende:

Public Function createPP(workbookName As String, Worksheet As String, title As String) As Boolean 
     Dim ppApp As PowerPoint.Application 
     Dim ppPres As PowerPoint.Presentation 
     Dim ppSlide As PowerPoint.Slide 
     Dim counter As Integer 
     Dim rng As Range 
     Dim lastRow As Integer, lastCol As Integer, lastRow1 As Integer, lastCol1 As Integer 
     Dim Worksheet2 As String 


     Set ppApp = New PowerPoint.Application 
     ppApp.Visible = True 
     ppApp.Activate 

     Sheets(Worksheet).Select 
     lastRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row 
     lastCol = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row 

     Sheets(Worksheet2).Select 
     lastRow1 = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row 
     lastCol1 = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row 

     Set ppPres = ppApp.Presentations.Add 
     ppPres.ApplyTemplate (ActiveWorkbook.Path & "\HPETheme.thmx") 
     Set ppSlide = ppPres.Slides.Add(1, ppLayoutCustom) 
     ppSlide.Shapes(1).TextFrame.TextRange = title 
     ppSlide.Shapes(2).TextFrame.TextRange = "per SPL per month" '& vbNewLine & "presented by Isabelle Schmiedel" 
     ppSlide.Shapes(3).TextFrame.TextRange = "Isabelle Schmiedel" 
     x = 2 


     For counter = 2 To lastRow - 1 
      Set rng = Workbooks(workbookName).Sheets(Worksheet).Range("A" & counter & ":J" & counter + 24) 
      Set ppSlide = ppPres.Slides.Add(x, 11) 
      ppSlide.Shapes(1).TextFrame.TextRange = Sheets(Worksheet).Cells(counter, 1) 
      ppSlide.Select 

      rng.Copy 

      ppSlide.Shapes.Paste 

      counter = counter + 25 
      x = x + 1 
     Next counter 
End Function 

Jemand weiß, was muss ich so funktioniert es ändern? Vielen Dank im Voraus.

Answer 1

Statt

ppSlide.Shapes.Paste 

diese versuchen, die Tabelle zu kopieren/Range direkt ::

ppApp.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting" 

Oder vielleicht:

ppApp.CommandBars.ExecuteMso "PasteSourceFormatting" 

Wenn Sie es vorziehen, eine Bild, dann Verwenden Sie dies:

ppApp.CommandBars.ExecuteMso "PasteAsPicture" 

Erläuterung:

https://stackoverflow.com/a/24644730/1467082

Wenn aus irgendeinem Grund die Schriftgröße nicht erhalten haben, können Sie so etwas wie dieses

Dim tRow as Long, tCol as Long, shp as Object, tbl as Object, tblCell as Object 

Set shp = ppSlide.Shapes(ppSlide.Shapes.Count) 
Set tbl = shp.Table 
For tRow = 1 to tbl.Rows.Count 
    For tCol = 1 to tbl.Columns.Count 
     Set tblCell = tbl.Cell(tRow, tCol) 
     # Assign each cell the same font size from corresponding cell in Excel range: 
     tblCell.Shape.TextFrame.TextRange.Font.Size = rng(tRow, tCol).Font.Size 
    Next 
Next 

tun Sie auch so etwas wie dies versuchen könnte, die ist ein bisschen hacky, aber könnte schneller sein als Zell-Iteration:

Set shp = ppSlide.Shapes(ppSlide.Shapes.Count) 
shp.Select 
While shp.Table.Cell(1,1).TextFrame.TextRange.Font.Size < 12 
    ppApp.CommandBars.ExecuteMso "FontSizeIncrease" 
Wend