vba 从 Excel 调用的宏以打开 PowerPoint 演示文稿、插入幻灯片和将范围复制到幻灯片有时有效，其他错误

Macro called from Excel to Open a PowerPoint Presentation, Insert a Slide, and Copy Range to Slide works sometimes, errors others

提问by Chris

Disclaimer- very new to writing VBA macros, but I have done a ton of research on here and other forums while trying to fix this error, all to no avail. Apologies if this has already been asked and answered, maybe I'm not searching correctly.

免责声明 - 编写 VBA 宏非常新，但我在尝试修复此错误时已在此处和其他论坛上进行了大量研究，但均无济于事。抱歉，如果这已经被问到并得到了回答，也许我没有正确搜索。

Now to the meat and potatos: I've been working on a VBA macro in Excel that will allow me to:

现在是肉和土豆：我一直在 Excel 中使用 VBA 宏，它可以让我：

1. Open a new or existing PowerPoint presentation
2. Paste a value to, and activate, a specific cell, which in turn populates the spreadsheet using a vlookupformula
3. Copy the values onlyfrom the first spreadsheet to a second one and then copy the second spreadsheet
4. Make PowerPoint visible and then insert a new slide at a certain point
5. Paste the Excel data to the new slide and position accordingly.

1. 打开新的或现有的 PowerPoint 演示文稿
2. 将值粘贴到并激活特定单元格，然后使用vlookup公式填充电子表格
3. 仅将第一个电子表格中的值复制到第二个电子表格，然后复制第二个电子表格
4. 使 PowerPoint 可见，然后在特定点插入新幻灯片
5. 将 Excel 数据粘贴到新幻灯片并相应地定位。

Whenever I run the macro with the PowerPoint presentation already open, it works perfectly. If I try to do it without the presentation open, it will prompt me to select the presentation file, open the PowerPoint, run the Excel functions, but then it hangs up when I try to make PowerPoint visible, add a slide, and paste the data. At Line 57 (pptApp.Visible = msoTrue)of the code below, the macro hangs and gives me the "Run-time error '91' Object variable or With block variable not set" message. I have been banging my head against this wall, but can't seem to find my error. Any help is appreciated.

每当我在 PowerPoint 演示文稿已经打开的情况下运行宏时，它都能完美运行。如果我尝试在没有打开演示文稿的情况下执行此操作，它会提示我选择演示文稿文件、打开 PowerPoint、运行 Excel 功能，但是当我尝试使 PowerPoint 可见、添加幻灯片并粘贴数据。在下面代码的第 57 行(pptApp.Visible = msoTrue)，宏挂起并显示“运行时错误‘91’对象变量或未设置块变量”消息。我一直在用头撞这堵墙，但似乎找不到我的错误。任何帮助表示赞赏。

Additionally, once this is working I plan to tweak it to create and insert a total of 25 slides. If anyone has ideas or advice on how I could do that with the first slide being created and added mid deck, and the following new slides continuing after, I'd love to hear it. Thanks!!

此外，一旦这个工作正常，我计划调整它以创建和插入总共 25 张幻灯片。如果有人对我如何通过创建第一张幻灯片并添加中间甲板以及接下来的新幻灯片有什么想法或建议，我很想听听。谢谢！！

Main Routine:

主要程序：

Sub Final_Copy()

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptLayout As PowerPoint.CustomLayout
Dim pptShape As PowerPoint.Shape
Dim ws As Worksheet
Dim MyCell As Range, MyRange As Range
Dim rng As Excel.Range

Set rng = ThisWorkbook.ActiveSheet.Range("B1:I24")
Set MyRange = Sheets("Titles").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Set ws = ThisWorkbook.Sheets("PBAC")

On Error Resume Next
Set pptApp = GetObject(, "PowerPoint.Application")
Err.Clear
If pptApp Is Nothing Then SelectPresentationType.Show


On Error GoTo 0

For Each MyCell In MyRange

    If MyCell.Value <> ("1100") Then
        Sheets("Titles").Select
        MyCell.Select
        Selection.Copy
        Sheets("PBAC").Select
        Sheets("PBAC").Range("B25").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Sheets("PBAC").Range("B25").Activate

        With ws.UsedRange
            .Copy
            ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count), Count:=1, Type:=xlWorksheet
            Sheets(Sheets.Count).Name = MyCell.Value
            Selection.PasteSpecial Paste:=xlPasteValues, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Selection.PasteSpecial Paste:=xlPasteColumnWidths
            Selection.PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False
            ActiveSheet.Rows("1").RowHeight = 44.25
            ActiveSheet.Rows("2").RowHeight = 34.5
            ActiveSheet.Rows("3").RowHeight = 18.75
            ActiveSheet.Rows("4").RowHeight = 31.5
            ActiveSheet.Rows("18").RowHeight = 31.5
            ActiveSheet.Rows("5:17").RowHeight = 21.75
            ActiveSheet.Rows("19:24").RowHeight = 21.75
            ActiveWindow.DisplayGridlines = False
            ActiveWindow.Zoom = 69
        End With
Set rng = ThisWorkbook.ActiveSheet.Range("B1:I24")
    pptApp.Visible = msoTrue
    pptApp.Activate
Set pptPres = pptApp.ActivePresentation
Set pptLayout = pptPres.Slides(1).CustomLayout
Set pptSlide = pptPres.Slides.AddSlide(17, pptLayout)
rng.Copy
pptSlide.Shapes.PasteSpecial ppPasteEnhancedMetafile
Set pptShape = pptSlide.Shapes(pptSlide.Shapes.Count)
With pptShape
  .LockAspectRatio = msoTrue
  .Width = 725
  .Height = 450
  .Top = 55
  .Left = 9
End With
Application.CutCopyMode = False

    End If
Next MyCell

End Sub

Code for SelectPresentationTypeUser Form used to select Existing or New Presentation:

用于选择现有或新演示文稿的SelectPresentationType用户表单代码：

Private Sub Create_New_Click()

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
    SelectPresentationType.Hide
Set pptApp = CreateObject(class:="PowerPoint.Application")
    pptApp.Visible = True
    pptApp.Activate
Set myPresentation = pptApp.Presentations.Add

End Sub

Private Sub Existing_Presentation_Click()

Dim strFilePath As String
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
    SelectPresentationType.Hide
    strFilePath = Application.GetOpenFilename
        If strFilePath = "False" Then Exit Sub
Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Open(strFilePath)
    pptApp.Visible = True

End Sub

回答by Steve Rindsberg

pptPres is dimmed in both your main routine and in your button click handler.

pptPres 在您的主程序和按钮单击处理程序中都变暗。

You set pptPres (the one in the click handler) to a a presentation, pptPres goes out of scope and disappears when you return from the button handler sub, the rest of your code has no reference to the presentation in ITs local copy of pptPres.

您将 pptPres（单击处理程序中的那个）设置为演示文稿，pptPres 超出范围并在您从按钮处理程序子返回时消失，您的其余代码没有引用 pptPres 的 IT 本地副本中的演示文稿。

Suggestion:

建议：

Write a function that shows the Open/Save dialog box (as you're already doing), opens the presentation and returns a reference to the presentation object to your main code.

编写一个函数来显示打开/保存对话框（正如您已经在做的那样），打开演示文稿并将对演示文稿对象的引用返回到您的主代码。