VBA Excel - > PWP - 复制时空白

Question

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

唯一的一点是，当我一步一步地去完美，但是当我运行它时，所有新的幻灯片都是空白的。

你有一个想法如何改善？

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 

Answer 1

尝试下面的代码，该代码作为注释内部的解释：

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