我的 VBA 代码无法识别粘贴到 Excel 中的形状。但是，如果我在调试中没有更改任何内容后运行代码，它会突然起作用

Question

因此，我正在编写这段代码，该代码应该循环遍历 Excel 中的多个表格并将其粘贴到 PowerPoint 中。这个过程运行良好。但是，在将表格粘贴为范围后，我尝试更改形状的尺寸（在我的幻灯片中为#7）。然而，此时代码

Set PPShape = PPSlide.Shapes(7)

并给我以下错误“对象“形状”的方法“项目”失败（参见图片）

因此，它不会将刚刚复制到 PowerPoint 中的形状识别为形状。

但是，一旦我单击“调试”并再次运行代码，而无需更改任何一行代码，它就可以工作了。然后，VBA 检测相应幻灯片上的形状 #7，并将其尺寸更改为给定参数。我尝试在不同的子例程中编写选择形状并调整其大小的过程，然后从原始子例程中调用该子例程。没有运气。而且，On Error 似乎也没有克服这个错误。有人知道如何解决这个问题吗？

Option Explicit
Sub DBible()

'Declaring all necessary PowerPoint variables
Dim PP As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PPShape As PowerPoint.Shape
Dim OriginFile As String 'File path to PowerPoint template

'Declaring all necessary Excek-l variables
Dim adminSh As Worksheet 'Sheet containing the data to be exported
Dim configRng As Range 'Selection of cells used to mark the exported ranges
Dim rng As Range 'Each individual cell within range
Dim vRange$ 'Cell address
Dim expRng As Range 'Range to be exported

'Dimension variables to resize and position exported shapes
Dim vWidth As Double
Dim vHeight As Double
Dim vTop As Double
Dim vLeft As Double
Dim vSlide_No As Double 'Slide in which range will be pasted

'Create and open PowerPoint
Set PP = CreateObject("PowerPoint.Application")

OriginFile = "https://'CompanyName-my.sharepoint.com/personal/CompanyName/Documents/Documents/PLS%20DO%20NOT%20TOUCH%20-%20BRP%20ORIGIN.pptx?web=1"
PP.Presentations.Open (OriginFile)
PP.Visible = True
PP.WindowState = ppWindowMaximized

Set PPPres = PP.ActivePresentation

'Select sheet where data will be exported from and define the origin of all the ranges
Set adminSh = Sheets("PERF-LIQ-VEL-BETA")
Set configRng = adminSh.Range("rng_sheets")

'Loop that starts process of copy pasting the ranges from Excel to PowerPoint
For Each rng In configRng

    With adminSh 'Defining value of variables or location in which value of variable can be found in the excel
        vRange$ = .Cells(rng.Row, 6).Address
        vTop = 127
        vLeft = 14.2
        vWidth = 692.64
        vHeight = 235
        vSlide_No = .Cells(rng.Row, 4).Value
    End With
    
    PPPres.Windows(1).Activate
    PPPres.Windows(1).View.GotoSlide (vSlide_No)
    
    Set expRng = Sheets("PERF-LIQ-VEL-BETA").Range(vRange$).CurrentRegion 'Set range from excel
    
    expRng.Copy 'Set range from excel
    PP.CommandBars.ExecuteMso "PasteSourceFormatting" 'Paste
    
    Set PPSlide = PPPres.Slides(vSlide_No)
    Set PPShape = PPSlide.Shapes(7) 'Set shape to be altered
    
    With PPShape 'Resize and position range
        .Top = vTop
        .Left = vLeft
        .Width = vWidth
        .Height = vHeight
    End With
    
    'Clear memory to avoid errors in process of copying next range
    Set PPShape = Nothing
    Set PPSlide = Nothing
    Application.CutCopyMode = False
    
Next rng 'Repeat
    
End Sub

Answer 1

尝试改变这些：

1.

PP.CommandBars.ExecuteMso "PasteSourceFormatting" 'Paste

到

PPSlide.Shapes.Paste

2.

Set PPShape = PPSlide.Shapes(7) 

到

Set PPShape = PPSlide.Shapes(PPSlide.Shapes.count) 

就像这样：

...
        expRng.Copy 'Set range from excel
        'PP.CommandBars.ExecuteMso "PasteSourceFormatting" 'Paste
        
        Set PPSlide = PPPres.Slides(vSlide_No)
        'Set PPShape = PPSlide.Shapes(7) 'Set shape to be altered
        PPSlide.Shapes.Paste
        
        Set PPShape = PPSlide.Shapes(PPSlide.Shapes.Count)
        
        With PPShape 'Resize and position range
            .Top = vTop
            .Left = vLeft
            .Width = vWidth
            .Height = vHeight
        End With
...

您还可以使用

PPSlide.Shapes.Paste

方法的返回 ShapeRange 对象来获取

PPShape

，如下所示：

...
        expRng.Copy 'Set range from excel
        'PP.CommandBars.ExecuteMso "PasteSourceFormatting" 'Paste
        
        Set PPSlide = PPPres.Slides(vSlide_No)
        'Set PPShape = PPSlide.Shapes(7) 'Set shape to be altered
        
        Dim sr As PowerPoint.ShapeRange
        
        DoEvents
        Set sr = PPSlide.Shapes.Paste
        
        'Set PPShape = PPSlide.Shapes(PPSlide.Shapes.Count)
        Set PPShape = sr.Item(sr.Count)
        
        With PPShape 'Resize and position range
            .Top = vTop
            .Left = vLeft
            .Width = vWidth
            .Height = vHeight
        End With
...

Answer 2

您的计算机很可能太快了，它在复制尚未完成时就处理了粘贴（关于此行为有很多问题）。通常提出的解决方案是延迟该过程，这可行，但如果计算机变得更快怎么办？更多延误？延迟应该持续多长时间？ [提示][1] 我发现最有趣且更优雅，使其也适用于我认为的类级别，是创建处理该问题的单独过程，因此我们应该确定在退出之前，复制和粘贴都已完成处理。下面是一个示例用法。正如您所看到的，该副本可以直接在 PowerPoint 和 Excel 中使用（因为它会搜索父级，无论是工作表还是幻灯片，也许 Word 也是如此？我不实用，所以我不能说），而对于粘贴您需要使用下面的一个（我还没有测试过，但我想它应该可以工作）。否则，他们可能只是

Object

缩短时间并采取所有可能性。

Sub caLLcopyPaste()
Dim sL As Slide: Set sL = ActivePresentation.Slides(1)
Dim sLTarget As Slide: Set sLTarget = ActivePresentation.Slides(2)
Dim sH As ShapeRange: Set sH = sL.Shapes.Range("Group 1")
Call copyShape(sH)
Call pasteShape(sLTarget)
End Sub


Sub copyShape(sH As ShapeRange)
sH.Parent.Shapes.Range(sH.Name).Copy
End Sub


Function pasteShape(sLTarget As Slide) As ShapeRange
Set pasteShape = sLTarget.Shapes.Paste
End Function

'Function pasteShapeWS(sLTarget As Worksheet) As ShapeRange
'Set pasteShape = sLTarget.Shapes.Paste
'End Function


  [1]: https://stackoverflow.com/a/50161397/18247317