Powerpoint VBA 循环所有幻灯片，检查标题，如果标题正确，将形状粘贴到另一个演示文稿

Question

目标：
-循环检查每张幻灯片的特定标题
-一旦找到标题
-复制图表和脚注的形状
-然后将它们粘贴到单独的演示文稿中。

备注：
- 演示文稿中的幻灯片没有标题，但位于 Shapes(1)
-我收到

run-time error '-2147024809 (80070057)': The specified value is out of range.

-这个错误出现在If语句

的行

Sub library_update()

Dim NTppt As Presentation
Set NTppt = Application.Presentations("Z:\NTPath\NLibrary.pptx")

Dim ppt As Presentation
Set ppt = Application.Presentations("Z:\NTPath\Library.pptm")

Dim sld as slide

For Each sld In NTppt.Slides
        If sld.Shapes(1).TextFrame.TextRange.Text = "Fixed Income - Yield Curves" Then
            With NTppt
                sld.Shapes.Range(Array(2, 3)).Copy
                ppt.Slides(1).Shapes.Paste
            End With
        End If
Next sld

End Sub

Answer 1

下面的解决方案有效。我不确定为什么我的代码会产生最初的运行时间错误，但我认为这与在我的一些 powerpoint 幻灯片中找不到形状 (1) 有关。

为了解决这个问题，我在所有幻灯片的所有形状中搜索了 "Fixed Income - Yield Curves"。

Sub library_update()

Dim NTppt As Presentation
Set NTppt = Application.Presentations("Z:\NTPath\NLibrary.pptx")

Dim ppt As Presentation
Set ppt = Application.Presentations("Z:\NTPath\Library.pptm")

Dim sld As Slide
Dim shp As Shape

For Each sld In NTppt.Slides
    For Each shp In sld.Shapes
        If shp.HasTextFrame Then
            Set txt_range = shp.TextFrame.TextRange
            'Confirm exact spelling and capitalization of the slides or an error will return
            If txt_range = "Fixed Income – Yield Curves" Then
                With NTppt
                    sld.Shapes.Range(Array(2, 3)).Copy
                    ppt.Slides(2).Shapes.Paste
                End With
            End If
        End If
    Next shp
Next sld


End Sub

Powerpoint VBA 循环所有幻灯片，检查标题，如果标题正确，将形状粘贴到另一个演示文稿

Powerpoint VBA Loop all slides, check title, if correct title, paste shapes to another presentation

powerpoint

vba