我有一个关于创建基于某些Excel文件的演示文稿的问题 . 我想在Excel文件中准备宏以自动创建PowerPoint演示文稿 .

我希望宏自动输入一个给定的文件 - >工作表 - >获取幻灯片的范围，复制并粘贴它作为演示文稿的图片，并给它适当的 Headers ，并通过循环到下一行并做同样的事情 .

我有两个问题要问你

  • 我不知道如何使用第一列来编号幻灯片，因为当前位于Excel中列表开头的幻灯片位于列表的末尾（所以我需要以其他方式执行）或基于第1栏（幻灯片编号） .

  • 是否可以打开一个包含所选模板的演示文稿，其中包含文件中的一些曲目（ "C \ mmm \ desktop \ files \ template.pptm" ）

屏幕我的Excel文件的样子：

enter image description here

低于VBA代码：

Option Explicit
Sub VBA_PowerPoint()

Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim MyWb As Workbook 'variable for workbook
Dim MyWs As Worksheet 'variable for worksheet

Application.DisplayAlerts = False

ThisWorkbook.Activate
Range("A2").Select

'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


'Do While
ThisWorkbook.Activate

Do While ActiveCell.Value <> ""
ThisWorkbook.Activate
Set MyWb = Workbooks.Open(Filename:=(ActiveCell.Offset(0, 1) & "\" & ActiveCell.Offset(0, 2)), UpdateLinks:=0, ReadOnly:=True) ' to be sure read-only open

'Worksheet Open from D2
ThisWorkbook.Activate
Set MyWs = MyWb.Worksheets(ActiveCell.Offset(0, 3).Value) 'now MyWs is referenced to the worksheet in column D

'we copy the range shown in column E
ThisWorkbook.Activate
MyWs.Range(ActiveCell.Offset(0, 4).Value).Copy

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

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

'title of the slide
ThisWorkbook.Activate
mySlide.Shapes(1).TextFrame.TextRange.Text = "" & ActiveCell.Offset(0, 5)

'after pasting, we go back to active workbook
Application.CutCopyMode = False
MyWb.Activate

MyWb.Close SaveChanges:=False  ' close file and don't save
Set MyWs = Nothing
Set MyWb = Nothing
ActiveCell.Offset(1, 0).Select 'we go 1 row down
Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
excel vba excel-vba powerpoint