编写 Excel VBA 代码/宏以使用 Excel 单元格值填充 Powerpoint 文本框

Question

我正在尝试获取 Excel 单元格中的值并填充 PowerPoint 文本框。我不想将 PowerPoint 表格链接到 Excel 电子表格，因为电子表格会不断变化，而且值并不总是在相同的行或相同的顺序中。

所以我正在编写这个 VBA 代码来尝试填充文本框。我做过很多 VBA，但从未尝试过这种组合。以下是我迄今为止所拥有的（更多的代码将用于额外的文本框，但需要先让一个工作）。我意识到这个问题与未正确处理的对象有关，但不知道如何纠正它。

我使用的是 Excel 和 PowerPoint 2007。粗体语句是我收到错误的地方 - 438 对象不支持此属性或方法。

谢谢！

 Sub valppt()

 Dim PPT As PowerPoint.Application
    Dim newslide As PowerPoint.Slide
    Dim slideCtr As Integer
    Dim tb As PowerPoint.Shape
    Set PPT = CreateObject("PowerPoint.Application")
    PPT.Visible = True

    PPT.Presentations.Open "C:\Documents\createqchart.pptx"

    Range("F2").Activate
    slideCtr = 1

    Set newslide = ActivePresentation.Slides(slideCtr).Duplicate
    Set tb = newslide.Shapes("TextBox1")

    slideCtr = slideCtr + 1
    ' Do Until ActiveCell.Value = ""
    Do Until slideCtr > 2
        If slideCtr = 2 Then
           tb.TextFrame2.TextRange.Characters.Text = ActiveCell.Value
        End If
        ActiveCell.Offset(0, 1).Activate
        slideCtr = slideCtr + 1

        If slideCtr = 38 Then
            Set newslide = PPT.ActivePresentation.Slides(slideCtr).Duplicate
            ActiveCell.Offset(1, -25).Activate
        End If

      Loop

   End Sub

5/17 更新

虽然幻灯片的复制工作正常，但我仍然无法评估文本框。在将值分配给文本框的语句之前，我无法提出正确的 set 语句。现在我什至没有一个固定的声明，因为我无法得到正确的声明。任何帮助表示赞赏。下面是最新的代码。

Sub shptppt()
'
' shptppt Macro
'

    Dim PPT As PowerPoint.Application
    Dim pres As PowerPoint.Presentation
    Dim newslide As PowerPoint.Slide
    Dim slideCtr As Integer
    Dim tb As PowerPoint.Shape


    Set PPT = CreateObject("PowerPoint.Application")
    PPT.Visible = True

    Set pres = PPT.Presentations.Open("C:\Documents\createqchart.pptx")

    Range("F2").Activate
    slideCtr = 1

    'Set newslide = ActivePresentation.Slides(slideCtr).Duplicate
    ' Set tb = newslide.Shapes("TextBox1")


    pres.Slides(slideCtr).Copy
    pres.Slides.Paste
    Set newslide = pres.Slides(pres.Slides.Count)
    newslide.MoveTo slideCtr + 1

    slideCtr = slideCtr + 1
    ' Do Until ActiveCell.Value = ""
    Do Until slideCtr > 2
        If slideCtr = 2 Then
            tb.Slides.TextFrame2.TextRange.Characters.Text = ActiveCell.Value
        End If
        ActiveCell.Offset(0, 1).Activate
        slideCtr = slideCtr + 1

        If slideCtr = 38 Then
            Set newslide = PPT.ActivePresentation.Slides(slideCtr).Duplicate
            ActiveCell.Offset(1, -25).Activate
        End If

    Loop

End Sub

Answer 1

txtReqBase 无效。它没有在您的代码中声明为变量，而且它肯定不是 Powerpoint 中受支持的属性/方法，这就是您收到 438 错误的原因。

要在形状中插入文本，您需要识别形状，然后操作其.Text。我发现使用形状变量最容易做到这一点。

'## If you have enabled reference to Powerpoint, then:'
Dim tb As Powerpoint.Shape
'## If you do not enable Powerpoint reference, use this instead'
'Dim tb as Variant '

Set tb = newSlide.Shapes("TextBox1")  '## Update this to use the correct name or index of the shapes collection ##'

tb.TextFrame2.TextRange.Characters.Text = ActiveCell.Value

更新对于不匹配错误设置tb。

我认为您收到不匹配错误是因为您有 PPT As Object，而不是启用对 Powerpoint 对象库的引用，这将允许您将其完全标注为 PowerPoint.Application。

您当前的代码解释 Dim tb as Shape 指的是 Excel.Shape，而不是 Powerpoint.Shape。

如果您启用对 Powerpoint 对象库的引用，那么您可以这样做

Dim PPT as Powerpoint.Application
Dim newSlide as Powerpoint.Slide
Dim tb as Powerpoint.Shape

如果您不想或无法启用对 PPT 对象库的引用，请尝试 Dim tb as Variant 或 Dim tb as Object，这可能会起作用。

更新 2 如何启用对 Powerpoint 的引用：

在 VBE 中，来自工具 |参考资料，勾选与您机器支持的 PPT 版本对应的复选框。在 Excel 2010 中，这是 14.0。 2007 年我认为是 12.0。

更新 3

Duplicate方法在2007年好像不可用。无论如何，在2010年也造成了一个奇怪的错误，虽然幻灯片复制正确，但变量没有设置。

试试这个：

Sub PPTTest()

Dim PPT As PowerPoint.Application
Dim pres As PowerPoint.Presentation
Dim newslide As PowerPoint.Slide
Dim slideCtr As Integer
Dim tb As PowerPoint.Shape

Set PPT = CreateObject("PowerPoint.Application")
PPT.Visible = True


'Control the presentation with a variable
Set pres = PPT.Presentations.Open("C:\users\david_zemens\desktop\Presentation1.pptx")

Range("F2").Activate
slideCtr = 1

'## This only works in 2010/2013 ##
'pres.Slides(slideCtr).Duplicate

'## Use this method in Powerpoint 2007 (hopefully it works)
pres.Slides(slideCtr).Copy
pres.Slides.Paste
Set newslide = pres.Slides(pres.Slides.Count)
newslide.MoveTo slideCtr + 1
...

Answer 2

我忘记了我已从文本框切换到 activex 控件文本框。这是正确的代码。

valppt()
Dim PPT As PowerPoint.Application
Dim newslide As PowerPoint.SlideRange
Dim slideCtr As Integer
Dim tb As PowerPoint.Shape
Set PPT = CreateObject("PowerPoint.Application")
PPT.Visible = True

PPT.Presentations.Open ("C:\Documents\createqchart.pptx")

Range("F2").Activate
slideCtr = 1

Set newslide = PPT.ActivePresentation.Slides(slideCtr).Duplicate
Set tb = newslide.Shapes("TextBox" & slideCtr)

slideCtr = slideCtr + 1
Do Until ActiveCell.Value = ""
'Do Until slideCtr > 2
    If slideCtr = 2 Then
       tb.OLEFormat.Object.Value = Format(ActiveCell.Value, "m/d/yyyy")
    End If
    ActiveCell.Offset(0, 1).Activate
    slideCtr = slideCtr + 1

    If slideCtr = 38 Then
        Set newslide = PPT.ActivePresentation.Slides(slideCtr).Duplicate
        ActiveCell.Offset(1, -25).Activate
    End If

Loop
End Sub