将excel中的动态范围导出到powerpoint

Question

我不熟悉将 excel 与其他应用程序链接，想知道是否有办法将我的电子表格复制并粘贴到 ppt 幻灯片中？唯一的事情是，我有一个包含数百行的电子表格。我正在寻找一种方法来循环遍历并粘贴电子表格，每张幻灯片 15 个，以及表格的标题。有什么办法吗？我脑海中的伪代码是这样的：

k=last row
for (i=0;i<k;i+15)
tbl.Row(i):tbl.Row(i+15) select
selection.copy into new ppt slide

这是我目前所拥有的：

    Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim i As Integer
i = 1
Do While i < 3
Set tbl = ActiveSheet.ListObjects("TableAll")
'Copy Range from Excel
  Set Rng = tbl.Rows((i), (i + 4)).Range

'Create an Instance of PowerPoint
  On Error Resume Next

    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")

    'Clear the error between errors
      Err.Clear

    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")

    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If

  On Error GoTo 0

'Optimize Code
  Application.ScreenUpdating = False


'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add

'Add a slide to the Presentation   


  Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly

'Copy Excel Range
  Rng.Copy

'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

    'Set position:
      myShape.Left = 66
      myShape.Top = 152

'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate

'Clear The Clipboard
  Application.CutCopyMode = False
  i = i + 1
Loop

提前致谢！

Answer 1

您采用的方法是将表格的图像复制然后粘贴到 PowerPoint 幻灯片中。这将迫使您将表格的副本创建到 Excel 的单独区域中，然后连续重塑（即删除行）以创建适合下一张幻灯片的表格。然后复制/PasteSpecial（作为图像）到 PowerPoint 幻灯片上。

我这里的做法是复制原始的 Excel 表格，然后将其以PowerPoint.Table 的形式复制到 PowerPoint。现在，您有了一个可以在 PowerPoint 中任意设置和操作的形状。

删除表（或范围）中的行时的棘手之处在于，通常最好从底部开始删除，以便跟踪行号/计数。

我在 Excel 中的测试数据开始时如下所示：

我的测试集中的总行数是 56。我有一列是预期的幻灯片编号。块着色只是为了在调试时便于查看。

所以伪代码是

copy the Excel table
set the "show area" to the top set of rows in the table
loop
    create a new slide
    copy the whole Excel table onto the slide
    delete all rows below "show area"
    delete all rows above the "show area"
    recalculate the next show area for the next slide
    exit the loop if the last slide is done
end loop

在构建了使用该逻辑进行处理的代码后，我的 Excel 表格被转换为 PowerPoint 演示文稿，幻灯片最终看起来像这样：

以这种方式使用复制/粘贴仍然（大部分）保留原始 Excel 表格的格式。例外是字体大小会自动减小（至少在我的 PowerPoint 设置中）。因此，我需要重置字体和列宽以实现所需的表格格式。您的设置可能不同。

另一个注意事项：我假设您希望在每张幻灯片上复制表格的标题行。 （这就是我想要的）

这是完整的代码：

Option Explicit

Sub CreateSlidesFromData()
    Const ROWS_PER_SLIDE As Long = 15

    '--- here's our data
    Dim tbl As ListObject
    Set tbl = ActiveSheet.ListObjects("TableAll")

    '--- attach to an existing PowerPoint instance or open a new one
    On Error Resume Next
    Dim PowerPointApp As PowerPoint.Application
    Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    If PowerPointApp Is Nothing Then
        Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    End If
    Err.Clear
    On Error GoTo 0

    '--- now we can create a presentation with a slide (title only)
    Dim myPresentation As PowerPoint.Presentation
    Dim mySlide As PowerPoint.Slide
    Set myPresentation = PowerPointApp.Presentations.Add

    '--- so copy the whole table to the clipboard...
    tbl.Range.Copy

    '--- ... and now loop to copy the table...
    Dim slideCount As Long
    slideCount = 1

    '--- must initialize these outside the loop
    Dim startingRowAboveGroupToDelete As Long
    Dim lastRowToDeleteBelow As Long
    startingRowAboveGroupToDelete = 0
    lastRowToDeleteBelow = startingRowAboveGroupToDelete + ROWS_PER_SLIDE + 1

    Dim lastSlide As Boolean
    lastSlide = False
    Do While True
        '--- add a new slide and paste the whole thing as a PowerPoint table shape
        Set mySlide = myPresentation.Slides.Add(slideCount, 11) '11 = ppLayoutTitleOnly
        mySlide.Shapes.Paste

        '--- now get the table shape to work with
        '    (probably could be broken out into a function)
        Dim slideTable As PowerPoint.Table
        Dim i As Long
        For i = 1 To mySlide.Shapes.Count
            If mySlide.Shapes(i).HasTable Then
                Set slideTable = mySlide.Shapes(i).Table
                Exit For
            End If
        Next i

        '--- first delete all the rows BELOW the group on this slide
        Debug.Print "Slide " & slideCount & ", deleting up to row " & lastRowToDeleteBelow
        For i = slideTable.Rows.Count To lastRowToDeleteBelow Step -1
            slideTable.Rows(i).Delete
        Next i

        '--- now delete all rows ABOVE the group that should be shown on this slide
        Debug.Print "Slide " & slideCount & ", start deleting above at row " & startingRowAboveGroupToDelete
        For i = startingRowAboveGroupToDelete To 2 Step -1
            slideTable.Rows(i).Delete
        Next i

        '--- finally a little formatting
        ChangeTableFont slideTable, "Arial", 12
        Dim shp As PowerPoint.Shape
        With slideTable
            .Columns(1).Width = 140
            .Columns(2).Width = 200
            .Columns(3).Width = 80
            .Columns(4).Width = 160
            .Columns(5).Width = 80
            Set shp = .Parent
            shp.Top = 200
            shp.Left = 50
            Debug.Print mySlide.Name & "(" & shp.Name & "): table position: left=" & shp.Left & ", top=" & shp.Top
        End With

        If lastSlide Then
            Exit Do
        End If

        '--- calculate for the next loop, which also checks to see if we're done
        slideCount = slideCount + 1
        startingRowAboveGroupToDelete = (ROWS_PER_SLIDE * (slideCount - 1)) - (slideCount - 2)
        lastRowToDeleteBelow = startingRowAboveGroupToDelete + ROWS_PER_SLIDE

        '--- add a new slide and (maybe) go back around
        If lastRowToDeleteBelow > tbl.DataBodyRange.Rows.Count Then
            '--- the next slide is the last slide
            lastSlide = True
        End If
    Loop
End Sub

Sub ChangeTableFont(ByRef slideTable As PowerPoint.Table, _
                    ByVal fontName As String, _
                    ByVal fontSize As Long)
    '--- based on an answer by Steve Rindsberg
    '    https://stackoverflow.com/a/31822059/4717755
    Dim lRow As Long
    Dim lCol As Long
    For lRow = 1 To slideTable.Rows.Count
        For lCol = 1 To slideTable.Columns.Count
            With slideTable.Cell(lRow, lCol).Shape.TextFrame.TextRange
                .Font.Name = fontName
                .Font.Size = fontSize
            End With
        Next lCol
    Next lRow
End Sub