通过 excel 处理 ppt 中的 OLE 对象有时会返回运行时错误 430

我有一个 Excel 工作簿，它在 ppt 中创建了一个摘要。它主要由我无法再联系的其他人编码。因此，我希望你们能帮助我。它基本上创建了 3 种不同类型的幻灯片，每种幻灯片 5 次。最后一种类型（从现在起 type_3）正在产生问题。它基本上从名为“powerpoint feeder”的工作表中获取一系列单元格，并将该范围作为OLE对象复制到powerpoint幻灯片。之后，我需要清理那里的一些细胞。使某些其他单元格中的文本溢出（= 可读），因为由于这些幻灯片上的空间有限，我无法调整列宽。现在，有时运行代码会为我提供运行时错误 430：“类不支持自动化或不支持预期接口”。调试器将我定向到以下代码中标记的特定行。错误不会发生，如果我打开excel，输入我的数据，然后运行它（没有其他powerpoint和excel打开）。如果我之后再次运行它，它会产生上述错误。关闭所有 Excel 和 powerpoint，然后重新打开 excel，然后再次运行代码将起作用。我假设，我没有正确处理 OLE 对象，因为我以前从未使用过它。

额外问题：我似乎在我的 5 张 Type_3 幻灯片的 OLE 对象中插入了整个 excel，使我的 20 张幻灯片 ppt 超过 8 MB（1 Excel = 大约 1.6 MB）。我不一定需要所有这些。但是，稍后可以对 PowerPoint 中的表格进行调整（但不一定在 excel/整个工作簿中），这一点很重要。

帮助将不胜感激！我希望，我说清楚了我的观点。

Sub Type_3(i_Anchor As Range, i_Title As String, index As Integer)
Dim rng As Range, cel As Range    


ActiveWorkbook.Sheets("Powerpoint feeder").Activate
Set rng = i_Anchor
num_columns = 8

With Sheets("Powerpoint feeder")     'Determine range
    test_cell = rng.Value
    i = 1
    Do While test_cell <> ""
        i = i + 1
        test_cell = .Cells(rng.Row + i, rng.Column)
    Loop

    num_rows = i - 1

    .Range(.Cells(rng.Row, rng.Column), .Cells(rng.Row + num_rows - 1, rng.Column + num_columns - 1)).Copy
End With

Position = 1 'Determine the position of the slide

For i = 0 To index - 1
    Position = Position + Type_1_index(i) + Type_2_index(i)
Next i

Position = Position + 1

Position = Position + Num_Type_3

Set New_slide = myPresentation.Slides.AddSlide(Position, myPresentation.SlideMaster.CustomLayouts(7))   'Create new slide

With New_slide
    .Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoFalse  'Create Table

    Set New_Table = .Shapes(.Shapes.Count)   'Set position in slide
    New_Table.Left = 30
    New_Table.Top = 95
    New_Table.Width = 660

   '****Next line produces error****     

With New_Table.OLEFormat.Object.Sheets("Powerpoint feeder")     
            Set rng = .Range(.Cells(rng.Row, rng.Column), .Cells(rng.Row + num_rows - 1, rng.Column))
            For Each cel In rng
                If Left(cel.Value, 1) = "A" Then
                    For x = 1 To 5
                        cel.Offset(0, x).ClearContents 'Enables headline overflow to adjacent empty cells
                    Next x
                End If
            Next cel
        End With

End With

Num_Type_3 = Num_Type_3 + 1

End Sub

编辑：

在@Domenic 的帮助下，我能够在没有链接的情况下创建表格以将尺寸缩小到初始尺寸的十分之一。伟大的！并且还使标题的可读性与下面的代码一起工作。但是，该代码仅在我“走过”它时才有效，而当我穿过它时则无效。每次运行它时，都会收到运行时错误“-2147467259 (80004005)”：对象“Shape”的方法“Table”失败。我尝试Application.Wait在错误之前添加。我试过了On Error Resume Next，我试过了DoEvents。没有什么可以让它发挥作用。有什么建议么？

`With New_slide
myPresentation.Windows(1).Activate
myPresentation.Windows(1).View.GotoSlide Position
.Application.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"

Set New_Table = .Shapes(.Shapes.Count)
    New_Table.Left = 30
    New_Table.Top = 95
    New_Table.Width = 660

        With New_Table.Table    '****ERROR OCCURS HERE****
            For iRow = 1 To .Rows.Count
                If Left(.Cell(iRow, 1).Shape.TextFrame.TextRange.Text, 1)= "A" Then
                   For iCol = 2 To 4
                        .Cell(iRow, iCol).Shape.TextFrame.TextRange.Text = ""
                   Next iCol
                   .Cell(iRow, 1).Merge MergeTo:=.Cell(iRow, 4)
                   .Rows(iRow).Height = 13.04 'Point equivalent of standard rows with a height of 0.46 cm
                End If
            Next iRow
        End With`

编辑2：

解决方案由 Domenic 提供。在粘贴后立即添加此延迟就足够了，而不会减慢代码太多。