在Powerpoint中插入Excel内容。错误消息：剪贴板为空或包含可能无法粘贴在此处的数据

Posted 2023-02-14

我正在尝试从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

答案

代替

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

您也可以尝试这样的操作，虽然有点麻烦，但可能比单元格迭代要快：

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

另一答案

一个以下使用sld.Shapes.PasteSpecial数据类型：= 0

或

sld.Shapes.PasteSpecial数据类型：= ppPasteShape