宏从Excel调用打开PowerPoint演示文稿，插入幻灯片和复制范围到幻灯片工作有时，错误其他

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

现在给肉和土 beans ：我一直在使用Excel中的VBA宏，这将允许我：

• 打开新的或现有的PowerPoint演示文稿

• 将值粘贴到并激活特定单元格，然后使用vlookup公式填充电子表格

• 将 values only 从第一个电子表格复制到第二个电子表格，然后复制第二个电子表格

• 使PowerPoint可见，然后在某个点插入新幻灯片

• 将Excel数据粘贴到新幻灯片并相应地定位 .

每当我在PowerPoint演示文稿已经打开的情况下运行宏时，它就能完美运行 . 如果我尝试在没有打开演示文稿的情况下执行此操作，它将提示我选择演示文稿文件，打开PowerPoint，运行Excel函数，但是当我尝试使PowerPoint可见，添加幻灯片并粘贴时，它会挂起数据 . 在下面代码的第57行（pptApp.Visible = msoTrue），宏挂起并给我"Run-time error '91' Object variable or With block variable not set"消息 . 我一直在撞墙，但似乎无法找到我的错误 . 任何帮助表示赞赏 .

此外，一旦这个工作，我打算调整它来创建和插入总共25个幻灯片 . 如果有人对我如何能够创建并添加第一张幻灯片以及继续添加以下新幻灯片的想法或建议，我很乐意听到它 . 谢谢！！

主要例程：

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 用户表单的代码：

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