Question

我有三个excel表中的数据，范围为a1：g16，我想将它发送到三个不同幻灯片的powerpoint。我在ozgrid上找到了一个可以正常工作的代码（在Microsoft PowerPoint 12.0 Object Library中使用Tools->References），但它会打开一个新的powerpoint文件。我想要做的是它应该打开一个保存的ppt文件并保留所有动画，过渡和主题。我搜索了一个但却无法弄清楚如何去做。有人可以对它有所了解，以便我可以从这里开始......我不介意从excel vba移动到powerpoint vba，如果有效的话。

此外，它会将幻灯片中的整个数据转储为幻灯片中的一个图像，并希望知道是否有办法将其分解。

由于

'Code to create PowerPoint Presentation and import Performance Pack data'
'from https://www.ozgrid.com/forum/forum/help-forums/excel-general/142599-multiple-powerpoint-slides-from-multiple-excel-sheets/page3
Sub PasteMultipleSlides()
 'Declare the variables we will be using'
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim PowerPointApp As PowerPoint.Application
Dim shp As PowerPoint.ShapeRange
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long

'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 Exit'
      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

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

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

'List of PPT Slides to Paste to'
  MySlideArray = Array(1, 2, 3)
'List of Excel Ranges to Copy from'
    MyRangeArray = Array(Sheet1.Range("A1:G16"), Sheet2.Range("A1:G16"), _
      Sheet3.Range("A1:G16"))

'Add the right Number of slides
For x = 1 To 3
  Set mySlide = myPresentation.Slides.Add(myPresentation.Slides.Count + 1, ppLayoutBlank)
  'x = x + 1
Next x

'Loop through Array data'
  For x = LBound(MySlideArray) To UBound(MySlideArray)
    'Copy Excel Range
        MyRangeArray(x).Copy

    'Paste to PowerPoint and position'
      On Error Resume Next
        Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
        Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
      On Error GoTo 0

    'Center Object'
      With myPresentation.PageSetup
        shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
        shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
      End With

  Next x
'Transfer Complete'
  Application.CutCopyMode = False
  ThisWorkbook.Activate
  MsgBox "Complete!"
End Sub

Answer 1

此视频不是您所需要的100％，而是显示如何将Excel表格自动写入Powerpoint中的现有表格。动画，过渡，主题将被保留：https://youtu.be/LOT3mTA6DF8

将数据从excel发送到powerpoint

1 个答案: