VBA Excel-->；PWP-复制时为空

我的宏有点问题。我知道它不是完美的，但至少它是有效的

唯一的问题是，当我一步一步走的时候，一切都很顺利，但是当我运行它的时候，所有的新幻灯片都是空白的

你有办法改进吗

Sub paste_toPPT()

Dim PowerPointApp As Object
Dim pptApp As Object
Dim pptPres As Object
Dim myRange As Excel.Range
Dim path As String
Dim DestinationPPT As String
Dim saveName As String
Dim image As Object
Dim IDe As String
Dim count As Integer

'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set pptApp = GetObject(Class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear

'If PowerPoint is not already open then open PowerPoint
If pptApp Is Nothing Then Set pptApp = 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

'Open template
DestinationPPT = "C:\Users\user\Desktop\ID Card\Kpi ID.pptx"
Set pptPres = pptApp.Presentations.Open(DestinationPPT)

Windows("KPI List - P2P KPI.xlsm").Activate
count = WorksheetFunction.CountA(Sheets("KPI List").Range("E:E")) - 1

For i = 8 To count
    Worksheets("KPI List").Select
    'ThisWorkbook.Sheets("KPI List").Select
    IDe = Worksheets("KPI List").Range(Cells(i, 5), Cells(i, 5))
    ThisWorkbook.Sheets("ID").Range("F4:F4") = IDe
    'Set the range to copy
    Windows("KPI List - P2P KPI.xlsm").Activate
    Worksheets("ID").Select
    Worksheets("ID").Shapes.Range(Array("Group 57")).Select
    Selection.Copy
    'Add slide & Paste data

    pptPres.Windows(1).Activate
    Set mySlide = pptPres.Slides.Add(1, 12)
    mySlide.Select
    pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
Next i

pptPres.SaveAs DestinationPPT

End Sub   

---

尝试下面的代码，代码中的解释作为注释：

Sub paste_toPPT()

Dim pptApp As Object
Dim pptPres As Object
Dim myRange As Excel.Range
Dim path As String
Dim DestinationPPT As String
Dim saveName As String
Dim image As Object
Dim IDe As String
Dim count As Integer

' added 2 worksheet objects
Dim wsKPI As Worksheet
Dim wsID As Worksheet

'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set pptApp = GetObject(, "PowerPoint.Application")
'Clear the error between errors
Err.Clear

'If PowerPoint is not already open then open PowerPoint
If pptApp Is Nothing Then Set pptApp = CreateObject("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

'Open template
DestinationPPT = "C:\Users\user\Desktop\ID Card\Kpi ID.pptx"
Set pptPres = pptApp.Presentations.Open(DestinationPPT)

' no need to Activate the workbook first, just set the worksheet objects
Set wsKPI = Workbooks("KPI List - P2P KPI.xlsm").Sheets("KPI List")
Set wsID = Workbooks("KPI List - P2P KPI.xlsm").Sheets("ID")

count = WorksheetFunction.CountA(ws.Range("E:E")) - 1

For i = 8 To count
    IDe = wsKPI.Range(wsKPI.Cells(i, 5), wsKPI.Cells(i, 5))
    wsID.Range("F4:F4") = IDe

    ' first add the slide , later do the copy>>paste as close as can be
    Set mySlide = pptPres.Slides.Add(1, 12)

    ' Set the range to copy (no need to Select first)
    wsID.Shapes.Range(Array("Group 57")).Copy

    mySlide.Select
    pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
Next i

pptPres.Save

End Sub

---

尝试下面的代码，代码中的解释作为注释：

Sub paste_toPPT()

Dim pptApp As Object
Dim pptPres As Object
Dim myRange As Excel.Range
Dim path As String
Dim DestinationPPT As String
Dim saveName As String
Dim image As Object
Dim IDe As String
Dim count As Integer

' added 2 worksheet objects
Dim wsKPI As Worksheet
Dim wsID As Worksheet

'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set pptApp = GetObject(, "PowerPoint.Application")
'Clear the error between errors
Err.Clear

'If PowerPoint is not already open then open PowerPoint
If pptApp Is Nothing Then Set pptApp = CreateObject("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

'Open template
DestinationPPT = "C:\Users\user\Desktop\ID Card\Kpi ID.pptx"
Set pptPres = pptApp.Presentations.Open(DestinationPPT)

' no need to Activate the workbook first, just set the worksheet objects
Set wsKPI = Workbooks("KPI List - P2P KPI.xlsm").Sheets("KPI List")
Set wsID = Workbooks("KPI List - P2P KPI.xlsm").Sheets("ID")

count = WorksheetFunction.CountA(ws.Range("E:E")) - 1

For i = 8 To count
    IDe = wsKPI.Range(wsKPI.Cells(i, 5), wsKPI.Cells(i, 5))
    wsID.Range("F4:F4") = IDe

    ' first add the slide , later do the copy>>paste as close as can be
    Set mySlide = pptPres.Slides.Add(1, 12)

    ' Set the range to copy (no need to Select first)
    wsID.Shapes.Range(Array("Group 57")).Copy

    mySlide.Select
    pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
Next i

pptPres.Save

End Sub

---

count=WorksheetFunction.CountA（ws.Range（“E:E”））-1应该是count=WorksheetFunction.CountA（wsKPI.Range（“E:E”））-1我认为count=WorksheetFunction.CountA（ws.Range（“E:E”）-1应该是count=WorksheetFunction.CountA（wsKPI.Range（“E”）-1我认为