Question

我正在尝试剪切我的Excel工作表的一些数据并将其粘贴为演示文稿中的图片。但通常会显示一条错误消息：Shapes（未知成员）：无效请求。剪贴板为空或包含可能未在此处粘贴的数据。有时它有时候会出现在更早的时候，有时它甚至会起作用并且所有幻灯我的代码如下：

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

在1以下使用 sld.Shapes.PasteSpecial数据类型：= 0

或

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

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

2 个答案: