Question

我编写了以下代码，将两个页面上的两个表格复制并粘贴到Powerpoint中作为图像，但我想要做的是如果我在Powerpoint中设置了一个表格模板并且有一个空白行，则复制表格行从Excel到Powerpoint，如果它超过，说Powerpoint中的20行启动一个具有相同模板的新页面。

我已经浏览了很多代码，但在复制到预设模板方面似乎没有任何动态。提前致谢

Sub CopytoPowerpoint

Dim PPApp As PowerPoint.Application
Dim PPSlide As PowerPoint.Slide
Dim PPPres As PowerPoint.Presentation
Set PPApp = CreateObject("Powerpoint.Application")
Dim SlideNum As Integer

Set Xlapp = GetObject(, "Excel.Application")

'input Powerpoint template
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
'path of the Powerpoint template
strPresPath = "C:\Documents and settings\Desktop\Product\ProductTemplate.pptx"
'save the new Presentation to be created
    strNewPresPath = "C:\Documents and Settings\Desktop\Product\ Monthly Reporting Pack-" & Format(Date, "dd-mmm-yyyy") & ".pptx"
    PPApp.Visible = True
    Set PPPres = PPApp.Presentations.Open(strPresPath)
    PPPres.Application.Activate

''define destination slide
    SlideNum = 2
    PPPres.Slides(SlideNum).Select
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

''define source sheet
    Sheets("Sheet1").Activate

'copy/paste from
    Xlapp.Range("Table1").Copy 
    PPSlide.Select
    With PPSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile)
            .Item(1).ScaleHeight 0.75, msoCTrue, msoScaleFromMiddle
            .Item(1).ScaleWidth 0.62, msoCTrue, msoScaleFromMiddle
            .Item(1).Left = 10
            .Item(1).Top = 120

    End With

''define destination slide
    SlideNum = 3
    PPPres.Slides(SlideNum).Select
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

''define source sheet
    Sheets("Sheet1").Activate
'copy/paste from
    Xlapp.Range("Table2").Copy
    With PPSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile)
            .Item(1).ScaleHeight 0.75, msoCTrue, msoScaleFromMiddle
            .Item(1).ScaleWidth 0.62, msoCTrue, msoScaleFromMiddle
            .Item(1).Left = 10
            .Item(1).Top = 120

   End With
' Close presentation
    PPPres.SaveAs strNewPresPath
    'PPPres.Close
    'Quit PowerPoint
    'PPApp.Quit


Xlapp.Visible = True
Application.CutCopyMode = False
MsgBox "Presentation Created", vbOKOnly + vbInformation

' Clean up

Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub

Answer 1

使用ExecuteMso方法（没有详细记录，但它非常便于在应用程序之间粘贴数据等），您应该能够这样做：

这是Excel表格：

以下是PowerPoint的输出：

这假设PPT中的表的大小是正确的列数。如果不是，您可能需要额外的逻辑来有条件地添加/删除列。这不会保留Excel中的任何格式，因此它依赖于PowerPoint表/模板中指定的表格样式。

Sub copyTableRowsToPPT()
    Dim tbl As ListObject
    Dim tblRows As Range
    Dim r As Long 'row counter
    Dim c As Long 'col counter
    Dim ppt As Object 'PowerPoint.Application
    Dim ppPres As Object 'PowerPoint.Presentation
    Dim ppSlide As Object 'PowerPoint.Slide
    Dim ppShape As PowerPoint.Shape 'PowerPoint.Shape
    Dim ppTable As PowerPoint.Table 'PowerPoint.Table
    'Handle the Table in Excel
    Set tbl = ActiveSheet.ListObjects("Table1")            ' Rename based on your table name
    'Get the ROWS from the Table in Excel
    Set tblRows = tbl.DataBodyRange.Rows


    'Get PowerPoint objects...
    Set ppt = GetObject(, "PowerPoint.Application")
    Set ppPres = ppt.presentations(1)
    Set ppSlide = ppPres.Slides(1)
    Set ppShape = ppSlide.Shapes("Content Placeholder 5")  ' Rename based on your Shape name
    Set ppTable = ppShape.Table

    ' Copy the rows (but not headers) from Excel
    tbl.DataBodyRange.Copy

    ppTable.Rows.Add.Cells(1).Select
    ' Paste in to PowerPoint, keeping the PowerPoint theme/formatting
    ppt.CommandBars.ExecuteMso ("PasteExcelTableDestinationTableStyle")

End Sub

如果您更喜欢使用Excel样式，也可以使用"PasteExcelTableSourceFormatting"完成。您可能已经收集了，您可以使用此方法将整个表复制/粘贴到PowerPoint中，而不是尝试插入到现有的“模板”表中。

我认为如果需要，可以将其修改为在PowerPoint中的其他幻灯片“拆分”表格。如果您坚持使用该实现，请告诉我，我可以更详细地更新答案。

使用预定义模板将表从Excel复制到Powerpoint

1 个答案: