使用VBA在PowerPoint中设置标题

Question

我是新的宏，我试图导出一些数据从Excel到PowerPoint演示文稿。我需要将Excel中的某些单元格作为PowerPoint中的标题。这里是我的代码：

Sub CrearPresentacion2() 

'Iniciar las variables 
Dim rng As Excel.Range 
Dim PowerPointApp As PowerPoint.Application 
Dim myPresentation As PowerPoint.Presentation 
Dim myShapeRange As PowerPoint.ShapeRange 

'Pedir al usuario un rango de celdas 
Set rng = Application.InputBox("Seleccione el Rango para hacer Presentación", Title:="Seleccionar Rango", Type:=8) 
On Error Resume Next 

'Hacer PowerPoint visible 
PowerPointApp.Visible = True 
PowerPointApp.Activate 

'Crear Nueva Presentacion 
Set myPresentation = PowerPointApp.Presentations.Add 

'Ciclo para copiar cada celda en una diapositiva 
For Each Cell In rng.Cells 
    Cell.Select 
    Selection.Copy 
    Dim ppSlide2 As PowerPoint.Slide 
    Dim x As Integer 
    x = myPresentation.Slides.Count + 1 
    If x = 1 Then 
     Set ppSlide2 = myPresentation.Slides.Add(Index:=x, Layout:=ppLayoutBlank) 
     PowerPointApp.ActivePresentation.Slides(x).Select 
     PowerPointApp.ActiveWindow.Selection.SlideRange.Select 
     Set myShapeRange = ppSlide2.Shapes.PasteSpecial(DataType:=ppPasteText) 
     Dim Header1 As String 
     Header1 = "Example" 
     Set myTitle = ppSlide2.Shapes.Title 
     myTitle.TextFrame.TextRange.Characters.Text = Header1 
    ElseIf x = 2 Then 
     Set ppSlide2 = myPresentation.Slides.Add(Index:=x, Layout:=ppLayoutBlank) 
     PowerPointApp.ActivePresentation.Slides(x).Select 
     PowerPointApp.ActiveWindow.Selection.SlideRange.Select 
     Set myShapeRange = ppSlide2.Shapes.PasteSpecial(DataType:=ppPasteText) 
    Else 
     Set ppSlide2 = myPresentation.Slides.Add(Index:=x, Layout:=ppLayoutText) 
     PowerPointApp.ActivePresentation.Slides(x).Select 
     PowerPointApp.ActiveWindow.Selection.SlideRange.Select 
     Set myShapeRange = ppSlide2.Shapes.PasteSpecial(DataType:=ppPasteText) 
    End If 
Next Cell 

CutCopyMode = False 

当计数器等于1，我需要插入一个“示例”的称号，但它说，“myTitle”对象不存在。在第二种情况下，我需要把电池作为标题，但我不知道如何使用功能

ppSlide2.Shapes.PasteSpecial（数据类型：= ppPasteText）

谢谢您的帮助。

Answer 1

对于第一个问题，您使用的是Layout:=ppLayoutBlank哪个没有不是有一个Title的形状。您应该使用包含标题形状的布局。

我将使用ppLayoutTitleOnly但您可以使用任何包含标题形状的布局。

对于第二种情况，让我们将Cell的值存储为字符串变量，然后使用它写入幻灯片的标题形状。没有必要使用Copy方法。我也会建议将你的声明移动到你的代码的顶部 - VBA不会有条件地处理DIM语句，所以没有什么理由将它们放到你的循环中，并且只会让你更难在后面找到需要修改一些东西。

注意此代码是不完整的，因此尚未经过测试。

Dim titleText As String 
Dim ppSlide2 As PowerPoint.Slide 
Dim x As Integer 
Dim Header1 As String 

PowerPointApp.Visible = True 
PowerPointApp.Activate 

'Crear Nueva Presentacion 
Set myPresentation = PowerPointApp.Presentations.Add 


'Ciclo para copiar cada celda en una diapositiva 
For Each Cell In rng.Cells 
    titleText = Cell.Value 

    x = myPresentation.Slides.Count + 1 
    If x = 1 Then 
     Set ppSlide2 = myPresentation.Slides.Add(Index:=x, Layout:=ppLayoutTitleOnly) 
     PowerPointApp.ActivePresentation.Slides(x).Select 
     PowerPointApp.ActiveWindow.Selection.SlideRange.Select 
     Set myShapeRange = ppSlide2.Shapes.PasteSpecial(DataType:=ppPasteText) 
     Header1 = "Example" 
     Set myTitle = ppSlide2.Shapes.Title 
     myTitle.TextFrame.TextRange.Characters.Text = Header1 
    ElseIf x = 2 Then 
     Set ppSlide2 = myPresentation.Slides.Add(Index:=x, Layout:=ppLayoutTitleOnly) 
     PowerPointApp.ActivePresentation.Slides(x).Select 
     PowerPointApp.ActiveWindow.Selection.SlideRange.Select 
     ' not sure what this next line does so I omit it 
     'Set myShapeRange = ppSlide2.Shapes.PasteSpecial(DataType:=ppPasteText) 
     Set myTitle = ppSlide2.Shapes.Title 
     '## Insert the titleText from Cell variable in this slide's Title shape: 
     myTitle.TextFrame.TextRange.Characters.Text = titleText 
    Else 
     Set ppSlide2 = myPresentation.Slides.Add(Index:=x, Layout:=ppLayoutText) 
     PowerPointApp.ActivePresentation.Slides(x).Select 
     PowerPointApp.ActiveWindow.Selection.SlideRange.Select 
     Set myShapeRange = ppSlide2.Shapes.PasteSpecial(DataType:=ppPasteText) 
    End If 
Next Cell 

CutCopyMode = False