Question

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

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 = Timer + 0.1 做计时器＆lt;鳍的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

宏在逐步但不在F5模式下工作

2 个答案: