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