Excel VBA为PPT表格应用样式时Shape对象Table方法报错求助

错误原因 #

• 粘贴类型不符合要求：使用DataType:=0（即ppPasteDefault）粘贴Excel区域时，得到的是嵌入的Excel OLE对象，而非PowerPoint原生表格，该类形状对象不存在Table属性，调用时直接触发报错。
• 变量类型定义错误：Dim otbl As TableObject中的TableObject是Excel原生对象类型，PowerPoint的表格对象类型为Table，且因为代码采用晚绑定方式调用PowerPoint（未提前引用PowerPoint类型库），跨应用对象应定义为Object避免类型不匹配。
• 遗漏变量定义：代码中PPT_Shape、myTitle均未提前定义，容易触发隐式声明错误。
• PowerPoint内置常量未识别：代码中使用的ppLayoutTitleOnly等pp开头的常量，在未引用PowerPoint类型库的Excel VBA环境中无法自动识别，建议直接使用常量对应数值。

修正后的完整代码 #

Sub ExcelRangeToPowerPoint()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'强制变量声明
Option Explicit

Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim PPT_Shape As Object
Dim myTitle As Object
Dim sPath As String
Dim project As String
Dim otbl As Object '晚绑定场景下定义为Object即可

'Set Title
project = Feuil1.Cells(2, "C") '去掉Cells参数的多余引号
'Set the template
sPath = "C:\Users\E049XXXX\OneDrive - XXX\XXX\"
'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("A1:N34")

'Create an Instance of PowerPoint
On Error Resume Next
    'Is PowerPoint already opened?
    Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    'Clear the error between errors
    Err.Clear
    'If PowerPoint is not already open then open PowerPoint
    If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
    If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
    End If
On Error GoTo 0

'Optimize Code
Application.ScreenUpdating = False

'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add

'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly

'Apply template
PowerPointApp.ActivePresentation.ApplyTemplate "C:\Users\E049XXXX\OneDrive - XXXX\Documents\XXXXX.thmx"

'Copy Excel Range
rng.Copy

'Paste to PowerPoint and position，修改DataType为1对应ppPasteRTF，粘贴为PowerPoint原生表格
mySlide.Shapes.PasteSpecial DataType:=1
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

'Set position:
myShape.Left = 66
myShape.Top = 152

'Add Title
Set myTitle = mySlide.Shapes.Title
myTitle.TextFrame.TextRange.Characters.Text = project

'Add style，先判断形状类型是否为表格（19对应ppTable）
Set PPT_Shape = myShape
If PPT_Shape.Type = 19 Then
    Set otbl = PPT_Shape.Table
    With otbl
        .ApplyStyle "{C083E6E3-FA7D-4D7B-A595-EF9225AFEA82}", True
    End With
Else
    MsgBox "粘贴结果不是PowerPoint原生表格，无法应用样式"
End If

'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate

'Clear The Clipboard
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

核心修改说明 #

• 将粘贴的DataType从0修改为1，粘贴结果为PowerPoint原生表格，支持调用Table属性
• 修正了otbl的变量类型，新增了遗漏的变量声明
• 增加了形状类型判断逻辑，避免异常调用
• 补充了代码结束后恢复ScreenUpdating的设置，避免Excel界面锁死

内容的提问来源于stack exchange，提问作者Pierre-Marie