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时，我需要插入＆＃34;示例＆＃34;标题，但它说＆＃34; myTitle＆＃34;对象不存在。在第二种情况下，我需要将单元格作为标题，但我不知道如何使用该函数

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

使用VBA在PowerPoint中设置标题

1 个答案: