Question

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

奖金问题：我似乎在我的5张Type_3幻灯片中插入了整个excel＆＃39; OLE对象，使我的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的帮助下，我能够创建没有excel链接的表格，将大小缩小到初始大小的十分之一。大！并且还使标题的可读性与下面的代码一起使用。但是，代码只有在我＆＃34; walk＆＃34;通过它，但不是当我经历它。每一次，我都会经历它，我得到运行时错误＆＃39; -2147467259（80004005）＆＃39;：方法＆＃39;表＆＃39;对象＆＃39;形状＆＃39;失败。我尝试在错误发生之前添加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提供。只需在粘贴之后立即添加此延迟就足够了，而不会过多地降低代码速度。

Answer 1

修改

在单步执行代码时不会出现错误这一事实表明在粘贴对象之前可能需要更多时间。我们可以尝试调用另一个过程，该过程将延迟该过程几秒钟，同时调用DoEvents函数。因此，首先将以下宏复制到您的模块中......

Sub Delay(Optional ByVal Secs As Integer = 3) Dim sngStartTime As Single sngStartTime = Timer Do Until Timer > sngStartTime + Secs DoEvents Loop End Sub

然后，在您的原始代码中，在复制范围后立即调用宏...

Delay

默认情况下，您的宏会自动延迟3秒。如果需要，您可以延迟一段时间。例如，要将它延迟5秒，您可以像这样调用它......

Delay 5

此外，粘贴后也可以直接调用延迟。

编辑结束 ------------------------------------- -------------------------------------------------- -------------------------

首先，将PasteSpecial的DataType参数更改为ppPasteHTML ...

.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse 'Create Table

然后，更改您的With/End With语句，如下所示......

Dim iRow As Long Dim iCol As Long With New_Table.Table For iRow = 1 To .Rows.Count If Left(.cell(iRow, 1).Shape.TextFrame.TextRange.Text, 1) = "A" Then For iCol = 2 To .Columns.Count .cell(iRow, iCol).Shape.TextFrame.TextRange.Text = "" Next iCol End If Next iRow End With

通过excel在ppt中寻址OLE对象有时会返回运行时错误430

1 个答案: