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的单独区域中，然后成功地重塑形状（即删除行）以创建适合下一张幻灯片的表。然后将/粘贴特殊（作为图像）复制到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

将Excel中的动态范围导出到PowerPoint

1 个答案: