微距一步一步的工作，但不是在F5模式

我有很多形狀複製粘貼從Excel文件到PowerPoint演示文稿（10張幻燈片）。當我使用F8執行宏時，它可以工作，但如果我直接執行它（使用按鈕或播放按鈕 - 三角形），它不會全部粘貼。例如第1張幻燈片中的1形狀正常。第二幻燈片什麼也沒有，第三幻燈片只有一半的形狀......並不尊重我在宏觀中的位置。我能看到的是，當它運行得更快（通過運行）時，它並沒有給每一步執行的時間，直到結束，所以它執行一部分代碼而不是其他部分。 PS：我最後沒有任何錯誤。微距一步一步的工作，但不是在F5模式

我試過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

來源

2015-12-21 municipum

我很久以前就遇到過這個問題。我認爲解決方案是重啓機器，F5鍵激發了代碼。

來源

2015-12-21 20:22:24

你好，機器重新啓動severals次，但沒有change.the F5執行宏，以便使快速和不執行所有的代碼！ – municipum

我在另一個論壇發現這個代碼，我將它改編關於我需要

鰭=定時器+ 0.1 做，當定時器<鰭的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

來源

2015-12-23 08:17:11 municipum

可能somone請幫助我嗎？ – municipum

微距一步一步的工作，但不是在F5模式

回答

相關問題