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

VBA Excel - ＆gt; PWP - 复制时为空白

1 个答案: