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