将 Excel 中的行复制并粘贴到 Powerpoint

Question

好的，这就是我要找的东西（我是新人，所以要温柔）：

将 excel 中的（默认格式）复制并粘贴到 powerpoint（仅来自 sheet）
我在 ppt 中只能容纳这么多行 - 所以在一张幻灯片填充后，我希望 ppt 创建一个新幻灯片
每张幻灯片的标题相同即可！
我只需要复制B:K列

就是这样，但是我被卡住了 :( 我知道下面的代码不是编写此代码的最佳方式，它包含我确信很容易发现的错误。我无法在任何地方找到如何执行此操作在网上。

这是我目前拥有的：

Sub ExcelRangeToPowerPoint()
Dim rng As Excel.Range
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape
Dim i As Integer

'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")

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

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

'Add a slide to the Presentation
  Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly)

 For i = 1 To 6
  'need to set focus to slde 1
   PowerPointApp.ActiveWindow.View.GotoSlide (1)

  'Deletes Title
  'mySlide.Shapes.Title.Delete

  'builds new title
  mySlide.Shapes.AddShape Type:=msoShapeRectangle, left:=9, Top:=6, Width:=702, Height:=30
  mySlide.Shapes(mySlide.Shapes.Count).Line.Visible = msoTrue
  mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Font.Size = 20
  mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
  mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
  mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Text = "Current Full Initiative Details – Branded Book as of " & Date
  mySlide.Shapes(mySlide.Shapes.Count).Name = "I am TITLE"
  mySlide.Shapes(mySlide.Shapes.Count).Line.ForeColor.RGB = RGB(0, 0, 0)
  mySlide.Shapes(mySlide.Shapes.Count).Line.Weight = 1
  mySlide.Shapes(mySlide.Shapes.Count).Fill.Visible = msoTrue
  mySlide.Shapes(mySlide.Shapes.Count).Fill.ForeColor.RGB = RGB(255, 255, 255)

  'Copy Range from Excel
  Set rng = ActiveWorkbook.Worksheets("RAW").Range("B1:K23")

  'Copy Excel Range
  rng.Copy

  'Paste to PowerPoint and position
  PowerPointApp.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault

  Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)

  'Set position:
  myShapeRange.left = 10
  myShapeRange.Top = 42
  myShapeRange.Height = 492
  myShapeRange.Width = 702

  ActiveWorkbook.Sheets("RAW").Rows("2:23").Delete

  Call myPresentation.Slides.Add(1, PpSlideLayout.ppLayoutTitleOnly)

  'Clear The Clipboard
  Application.CutCopyMode = False

Next i

End Sub

Answer 1

根据评论中的要求，这是我用来将幻灯片从主 PPT 模板复制到报告 PPT 的代码。

那里有一些无关的代码，用于提供我们用来驱动流程的表单的状态更新，以及我可以在运行时间切换 on/off 的调试标志 - 这些都可以去掉。

这将作为找到适合您的情况的正确解决方案的起点，而不是所问问题的完整答案。

'I've chosen to declare these globally, though it's probably not the best way:
Dim PPTObj As PowerPoint.Application
Dim PPTMaster As PowerPoint.Presentation
Dim PPTClinic As PowerPoint.Presentation


Private Sub InsertPPT(ByVal SlideName As String, ByVal StatusText As String)

Dim Shp As PowerPoint.Shape
Dim Top As Single
Dim Left As Single
Dim Height As Single
Dim width As Single


  PPTMaster.Slides(SlideName).Copy
  PPTClinic.Slides.Paste
  Form_Master.ProcessStatus.Value = StatusText & " InsertPPT"
  With PPTClinic.Slides(PPTClinic.Slides.count)
    If Debugging Then
      .Select
    End If
    .Design = PPTMaster.Slides(SlideName).Design              'this ensures we get all the right formatting - only seems to be necessary 1 time, but we'll just do it on all
    .ColorScheme = PPTMaster.Slides(SlideName).ColorScheme
    .FollowMasterBackground = PPTMaster.Slides(SlideName).FollowMasterBackground
    For Each Shp In .Shapes                                                 'loop through all the shapes on the slide
      If Debugging Then
'          .Select
        Shp.Select
      End If
      Form_Master.ProcessStatus.Value = StatusText & " InsertPPT-" & Shp.Name
      If Shp.Type = msoLinkedOLEObject Then                                 'when we find a linked one
        ReLinkShape Shp, TempVars!NewXLName
        'need to store off top, left, width, height
        Top = Shp.Top
        Left = Shp.Left
        Height = Shp.Height
        width = Shp.width
        Shp.LinkFormat.Update                                               'and force the link to refresh
        MySleep 2, "S"                                                      'hopefully, the 2 second pause will allow everything to update properly before moving on.
        'then reset them here - they seem to change shape when I update them
        Shp.LockAspectRatio = msoFalse
        Shp.Top = Top
        Shp.Left = Left
        Shp.width = width
        Shp.Height = Height
      ElseIf Shp.Name = "SlideName" And Not Debugging Then                  'if it's the "SlideName" tag
        Shp.Delete                                                          'delete it (unless we're debugging)
      End If
    Next
  End With

  Form_Master.ProcessStatus.Value = StatusText

End Sub

Private Sub ReLinkShape(ByRef Shp As PowerPoint.Shape, ByVal NewDestination As String)

  Dim Link() As String
  Dim link2() As String

  If Shp.Type = msoLinkedOLEObject Then                                 'when we find a linked one
    Link = Split(Shp.LinkFormat.SourceFullName, "!")                    'update the link to point to the new clinic spreadsheet instead of the master
    If InStr(1, Link(2), "]") > 0 Then
      link2 = Split(Link(2), "]")
      Link(2) = "[" & TempVars!ClinicName & ".xlsx]" & link2(1)
    End If

    Shp.LinkFormat.SourceFullName = NewDestination & "!" & Link(1) & "!" & Link(2)
  End If

End Sub

Public Sub MySleep(ByRef Unit As Double, ByRef UOM As String)

Dim Pause As Date

  Pause = DateAdd(UOM, Unit, Now())
  While Now < Pause
    DoEvents
  Wend

End Sub

将 Excel 中的行复制并粘贴到 Powerpoint

Copy and paste rows from Excel to Powerpoint

vba

excel

powerpoint