宏以分步方式工作，但不以F5模式工作

Question

我有许多形状要从Excel文件复制粘贴到PowerPoint演示文稿(10张幻灯片)。当我使用F8执行宏时，它可以工作，但如果我直接执行它(使用按钮或播放按钮-三角形-)，它不会全部粘贴。例如，第一张幻灯片中的1个形状。第二张幻灯片什么也没有，第三张幻灯片只有一半的形状...并且不尊重我在宏中给出的位置。我看到的是，当它运行得更快(通过run)时，它不会给每个步骤提供执行到最后的时间，所以它执行的是代码的一部分，而不是其他部分。

PS:我最后没有任何错误。

我尝试过DoEvents，但没有任何变化。

Sub copierppt()
Dim PPT As PowerPoint.Application
Dim PptDoc As PowerPoint.Presentation
Dim NbShpe As Byte
Dim i As Integer

Set PPT = CreateObject("Powerpoint.Application")
PPT.Visible = True 'l'application sera visible
Set PptDoc = PPT.Presentations.Open("D:\Users\MATRIX.pptx")

    '5 ###################  slide 5 ####################
    PPT.ActiveWindow.View.GotoSlide Index:=5
    ThisWorkbook.Worksheets("names").ChartObjects("names graphe1").Copy
    PPT.ActiveWindow.Panes(1).Activate
    PPT.CommandBars.ExecuteMso ("PasteSourceFormatting")
    NbShpe = PptDoc.Slides(5).Shapes.Count
    With PptDoc.Slides(5).Shapes(NbShpe)
        .Name = "names graphe1"
        .Left = 50
        .Top = 230
        .Height = 270
        '.Width = 350
    End With
    DoEvents

    ' 6 ###################  slides 6 ####################
    PPT.ActiveWindow.View.GotoSlide Index:=6
    ThisWorkbook.Worksheets("surmane").ChartObjects("surname graphe1").Copy
    PPT.ActiveWindow.Panes(1).Activate
    PPT.CommandBars.ExecuteMso ("PasteSourceFormatting")
    NbShpe = PptDoc.Slides(6).Shapes.Count
    With PptDoc.Slides(6).Shapes(NbShpe)
        .Name = "Open surname graphe1"
        .Left = 50
        .Top = 230
        .Height = 270
        '.Width = 350
    End With

    ' 7 ################### slide 7 ####################
    PPT.ActiveWindow.View.GotoSlide Index:=7
    ThisWorkbook.Worksheets("adress").ChartObjects("adress graphe1").Copy
    PPT.ActiveWindow.Panes(1).Activate
    PPT.CommandBars.ExecuteMso ("PasteSourceFormatting")
    DoEvents
    NbShpe = PptDoc.Slides(7).Shapes.Count
    With PptDoc.Slides(7).Shapes(NbShpe)
        .Name = "adress graphe1"
        .Left = 50
        .Top = 230
        .Height = 270
        '.Width = 350
    End With

    ' 8 ################### slide 8 ####################
    PPT.ActiveWindow.View.GotoSlide Index:=8
    ThisWorkbook.Worksheets("statut").ChartObjects("statut graphe1").Copy
    PPT.ActiveWindow.Panes(1).Activate
    PPT.CommandBars.ExecuteMso ("PasteSourceFormatting")
    NbShpe = PptDoc.Slides(8).Shapes.Count
    With PptDoc.Slides(8).Shapes(NbShpe)
        .Name = "statut graphe1"
        .Left = 50
        .Top = 240
        .Height = 300
        '.Width = 350
    End With

    Sheets("statut").Activate
    Sheets("statut").Range("G21").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy

    PPT.ActiveWindow.Panes(1).Activate

    PPT.CommandBars.ExecuteMso ("PasteSourceFormatting")
    NbShpe = PptDoc.Slides(8).Shapes.Count

    With PptDoc.Slides(8).Shapes(NbShpe)
        .Name = "TCD1"
        .Left = 88
        .Top = 205
        '.Height = 520
        '.Width = 20
    End With

End Sub

Answer 1

我很久以前就遇到过这种情况。我认为解决方案是重新启动机器，然后按F5键就可以很好地触发代码。

Answer 2

我在另一个论坛上发现了这个代码，我根据我的需求对其进行了修改

fin =定时器+ 0.1 Do而定时器< fin DoEvents环路

它有时会给出预期的结果，但1/7次不会给出预期的结果。但我需要把它放在每一步中，并在计时器+1或+0.1，0.5后改变值……

enter code here
Sub copierppt()
Dim PPT As PowerPoint.Application
Dim PptDoc As PowerPoint.Presentation
Dim NbShpe As Byte
Dim i As Integer

Set PPT = CreateObject("Powerpoint.Application")
PPT.Visible = True 'l'application sera visible
Set PptDoc = PPT.Presentations.Open("D:\Users\MATRIX.pptx")
'5 ###################  slide 5 ####################
PPT.ActiveWindow.View.GotoSlide Index:=5
ThisWorkbook.Worksheets("names").ChartObjects("names graphe1").Copy
PPT.ActiveWindow.Panes(1).Activate
PPT.CommandBars.ExecuteMso ("PasteSourceFormatting")

fin = Timer + 0.1
Do While Timer < fin
DoEvents
Loop
NbShpe = PptDoc.Slides(5).Shapes.Count
With PptDoc.Slides(5).Shapes(NbShpe)

fin = Timer + 0.1
Do While Timer < fin
DoEvents
Loop
    .Name = "names graphe1"
    .Left = 50
    .Top = 230
    .Height = 270
    '.Width = 350
fin = Timer + 0.1
Do While Timer < fin
DoEvents
Loop
End With
DoEvents
' 6 ###################  slides 6 ####################
PPT.ActiveWindow.View.GotoSlide Index:=6
ThisWorkbook.Worksheets("surmane").ChartObjects("surname graphe1").Copy
PPT.ActiveWindow.Panes(1).Activate
PPT.CommandBars.ExecuteMso ("PasteSourceFormatting")
fin = Timer + 0.1
Do While Timer < fin
DoEvents
Loop
NbShpe = PptDoc.Slides(6).Shapes.Count
With PptDoc.Slides(6).Shapes(NbShpe)
    .Name = "Open surname graphe1"
    .Left = 50
    .Top = 230
    .Height = 270
    '.Width = 350
fin = Timer + 0.1
Do While Timer < fin
DoEvents
Loop
End With
'
'
'
' the same in every step for all the code
End Sub