使用预定义的模板将表从Excel复制到Powerpoint [英] Copying Table from Excel into Powerpoint using a predefined template

问题描述

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

我已经查看了很多代码，但是在复制到预设模板方面，似乎没有什么似乎是动态的。感谢提前

  Sub CopytoPowerpoint 
 
 Dim PPApp As PowerPoint.Application 
 Dim PPSlide As设置PPApp = CreateObject（Powerpoint.Application）
 Dim SlideNum As Integer 
 
 Set Xlapp = GetObject（， Excel.Application）
 
'输入Powerpoint模板
 Dim strPresPath As String，strExcelFilePath As String，strNewPresPath As String 
'Powerpoint模板的路径
 strPresPath = C：\Documents and settings\Desktop\Product\ProductTemplate.pptx
'保存要创建的新演示文稿
 strNewPresPath =C：\Documents and Settings\Desktop\\ \\Product\ Monthly Reporting Pack-&格式（日期，dd-mmm-yyyy）& .pptx
 PPApp.Visible = True 
设置PPPres = PPApp.Presentations.Open（strPresPath）
 PPPres.Application.Activate 
 
''定义目标幻灯片
 SlideNum = 2 
 PPPres.Slides（SlideNum）。选择
设置PPSlide = PPPres.Slides（PPApp.ActiveWindow.Selection.SlideRange.SlideIndex）
 
''定义源表
表（Sheet1）。从
 Xlapp.Range（Table1）激活
 
'复制/粘贴复制
 PPSlide.Select $ 
 
 $ b （1）.Left = 10 
 .Item（1）.Top = 120 
 
结束
 
''定义目标幻灯片
 SlideNum = 3 
 PPPres.Slides（SlideNum）。选择
设置PPSlide = PPPres.Slides（PPApp.ActiveWindow.Selection.SlideRange.SlideIndex）
 
 $'定义源表
表（Sheet1）。从
 Xlapp.Range（Table2）激活
'复制/粘贴。复制
使用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 
 
结束
'关闭演示
 PPPres.SaveAs strNewPresPath 
'PPPres.Close 
 '退出PowerPoint 
'PPApp.Quit 
 
 
 Xlapp.Visible = True 
 Application.CutCopyMode = False 
 MsgBoxPresentation Created，vbOKOnly + vbInformation 
 
'清理
 
设置PPSlide = Nothing 
设置PPPres = Nothing 
设置PPApp = Nothing 
 End Sub 
  

解决方案

使用 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 
'处理Excel中的表
设置tbl = ActiveSheet.ListObjects （Table1）'根据您的表名重命名
'从Excel中获取ROWS 
设置tblRows = tbl.DataBodyRange.Rows 
 
 
'获取PowerPoint对象... 
设置ppt = GetObject（，PowerPoint.Application）
设置ppPres = ppt.presentations（1）
设置ppSlide = ppPres.Slides（1）
设置ppShape = ppSlide.Shapes（内容占位符5）根据您的形状名称重命名
设置ppTable = ppShape.Table 
 
'从Excel复制行（但不是标题）
 tbl.DataBodyRange.Copy 
 
 ppTable.Rows.Add.Cells（ 1）。选择
'粘贴到PowerPoint，保持PowerPoint主题/格式
 ppt.CommandBars.ExecuteMso（PasteExcelTableDestinationTableStyle）
 
 End Sub 
  

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

如果需要，我相信这可以修改为在PowerPoint中的其他幻灯片上拆分表。如果你坚持这个实现，让我知道，我可以更详细地更新答案。

I have written the below code to copy and paste two tables over two pages into Powerpoint as an image, what I would like to do however is if I have a table template already set up in Powerpoint with one blank row, copy the table rows from Excel into Powerpoint and if it goes over say 20 rows in Powerpoint start a new page with the same template.

I have looked through lots of codes but nothing seems to be dynamic for what I am after in terms of copying to a pre set template. Thanks in advance

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

解决方案

Using the ExecuteMso method (not well documented, but it comes in very handy for pasting data between applications, etc.), you should be able to do this:

Here is the Excel table:

And here is the output to PowerPoint:

This assumes that the table in PPT is sized with the correct number of columns. If it is not, you may need additional logic to add/remove columns conditionally. This does not preserve any formatting from Excel, so it is relying on the table Style as specified in the PowerPoint table/template.

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

If you would prefer to use the Excel style, that can also be done using "PasteExcelTableSourceFormatting". As you may have gathered, you could just use this method to copy/paste the entire table in to PowerPoint, rather than trying to insert to an existing "template" table.

I believe this could be modified to "split" the table over additional slides in PowerPoint, if needed. If you're stuck on that implementation, let me know and I can update the answer with more detail.

这篇关于使用预定义的模板将表从Excel复制到Powerpoint的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！