macros从Excel调用打开PowerPoint演示文稿，插入一个幻灯片和复制范围滑动作品有时，错误的其他人

免责声明 – 写VBAmacros很新，但是我在这里和其他论坛上做了大量的研究，试图解决这个错误，都没有用。 道歉，如果这已被问及答复，也许我不正确search。

现在到肉和potatos：我一直在Excel中的VBAmacros，这将允许我：

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

每当我运行的PowerPoint演示文稿已经打开的macros，它完美的作品。 如果我尝试在未打开演示文稿的情况下尝试这样做，它会提示我select演示文稿文件，打开PowerPoint，运行Excel函数，但是当尝试使PowerPoint可见时，会挂起，添加幻灯片并粘贴数据。 在下面代码的第57行（pptApp.Visible = msoTrue）中，macros挂起并给出了“运行时错误”91“对象variables或块variables未设置”消息。 我一直在撞墙，但似乎无法find我的错误。 任何帮助表示赞赏。

此外，一旦这个工作，我打算调整它创build和插入总共25幻灯片。 如果任何人有想法或build议，我可以做到这一点，第一张幻灯片正在创build，并添加中间甲板，以下新的幻灯片继续后，我很想听到它。 谢谢！！

主要例程：

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 

用于SelectPresentationType用户表单的代码用于select现有或新build表示：

 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 

Answer 1

pptPres在你的主例程和你的button点击处理程序中变暗。

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

build议：

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