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

Writing Excel VBA code/macro to populate Powerpoint Text boxes with Excel cell values

提问by Spiderman

I am attempting to take the value in Excel cells and populate PowerPoint text boxes. I don't want to link a PowerPoint table to an Excel spreadsheet because the spreadsheet is constantly changing and values are not always in the same rows or the same order.

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

So I am writing this VBA code to try and populate the text boxes. I've done a lot of VBA, but never attempted this combination. Below is what I have thus far (more code will be put in for additional text boxes, but need to get one working first). I realize the issue has something to do with the object not being properly handled, but not sure how to correct it.

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

I'm using Excel and PowerPoint 2007. The bold statement is where I receive the error - 438 object does not support this property or method.

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

Thanks!

谢谢！

 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

UPDATE 5/17

更新 5/17

While the replication of the slide works, I am still unable to value the textbox. I haven't been able to come up with the right set statement prior to the statement to have the value assigned to the textbox. Right now I don't even have a set statement in there right now, because I haven't been able to get the proper one. Any assistance is appreciated. Below is the latest code.

虽然幻灯片的复制有效，但我仍然无法评估文本框。我无法在语句之前提出正确的 set 语句以将值分配给文本框。现在我什至没有一个 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

回答by David Zemens

txtReqBaseis not valid. it's not declared as a variable in your code, and it's certainly not a supported property/method in Powerpoint, and that's why you're getting the 438 error.

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

To insert text in a shape, you need to identify the shape and then manipulate its .Text. I find it easiest to do this with a shape variable.

要在形状中插入文本，您需要识别该形状，然后操作其.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

UPDATEFor Mismatch error setting tb.

更新不匹配错误设置tb。

I'm thinking you're getting the mismatch error because you have PPT As Objectrather than enabling a reference to the Powerpoint Object Library which would allow you to fully dimension it as a PowerPoint.Application.

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

Your current code interprets Dim tb as Shaperefers to an Excel.Shape, not a Powerpoint.Shape.

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

If you enable reference to the Powerpoint Object Library, then you can do

如果您启用对 Powerpoint 对象库的引用，那么您可以执行

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

If you don't want to, or can't enable reference to the PPT object library, try to Dim tb as Variantor Dim tb as Objectand that might work.

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

UPDATE 2How to enable reference to Powerpoint:

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

In the VBE, from Tools | References, check the box corresponding to the PPT version supported on your machine. In Excel 2010, this is 14.0. In 2007 I think it is 12.0.

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

Update 3

更新 3

The DuplicateMethod does not appear to be available in 2007. In any case, it also causes a strange error in 2010, although the slide is copied correctly, the variable is not set.

该Duplicate方法不会出现在2007年可在任何情况下，它也导致一个奇怪的错误在2010年，虽然幻灯片正确复制，变量未设置。

Try this instead:

试试这个：

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
...

回答by Spiderman

I had forgotten that I had switched from a textbox to an activex control textbox. here's the correct code now.

我忘记了我已经从文本框切换到 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