在 Powerpoint 中插入 Excel 內容。 錯誤消息：剪貼板為空或包含可能無法粘貼到此處的數據

Question

我正在嘗試從 Excel 工作表中復制數據並將其作為圖片粘貼到演示文稿中。

通常會顯示錯誤消息說：

形狀（未知成員）：無效請求。 剪貼板為空或包含可能無法粘貼到此處的數據。

有時它出現較早有時較晚，有時它甚至可以工作並且所有幻燈片都已創建。

我的代碼如下：

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

Answer 1

而不是

ppSlide.Shapes.Paste

試試這個直接復制表/范圍::

ppApp.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"

或者可能：

ppApp.CommandBars.ExecuteMso "PasteSourceFormatting"

如果您更喜歡圖片，請使用以下命令：

ppApp.CommandBars.ExecuteMso "PasteAsPicture"

說明：

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

如果由於某種原因未保留字體大小，您可以執行以下操作

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

你也可以嘗試這樣的事情，這有點hacky，但可能比單元迭代更快：

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

Answer 2

使用下面一個 sld.Shapes.PasteSpecial DataType:=0

或

sld.Shapes.PasteSpecial DataType:=ppPasteShape