java xls 布局_从Excel到PowerPoint - 编号幻灯片自定义布局

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

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

我有两个问题要问你

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

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

屏幕我的Excel文件的样子：

低于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