Макрос для копирования и вставки нескольких диапазонов Excel в PPT - PullRequest
Новая
       17

Макрос для копирования и вставки нескольких диапазонов Excel в PPT

0 голосов
/ 25 октября 2018

Я наконец-то смог создать этот макрос, который копирует данные из определенного диапазона в Excel и вставляет их в существующий PPT.

Теперь я хочу повторить это действие для нескольких слайдов, но вместоСкопируйте и вставьте этот макрос снова и снова, есть ли какой-нибудь более короткий код, где я просто изменяю диапазон, целевой слайд, позиционирование и создаю полный набор.

Вот существующий код, который работает нормально: 

'Macro1
Sub excelrangetopowerpoint_month()

    Dim rng As Range
    Dim powerpointapp As Object
    Dim mypresentation As Object
    Dim destinationPPT As String
    Dim myshape As Object
    Dim myslide As Object

    Set rng = Worksheets("objectives").Range("m1")

    On Error Resume Next

    Set powerpointapp = CreateObject("powerpoint.application")
    destinationPPT = ("C:\Users\OLX-Admin\Dropbox (Corporate Finance)\Naspers Monthly Reporting\Prep for call\From teams\FY2019\OLX Group Monthly Report_Sep'18_Macro.pptx")
    powerpointapp.Presentations.Open (destinationPPT)

    On Error GoTo 0

    Application.ScreenUpdating = False

    Set mypresentation = powerpointapp.ActivePresentation
    Set myslide = mypresentation.Slides(1)

    rng.Copy

    myslide.Shapes.PasteSpecial DataType:=2 '2 = enhanced metafile
    Set myshape = myslide.Shapes(myslide.Shapes.Count)

    myshape.Left = 278
    myshape.Top = 175

    powerpointapp.Visible = True
    powerpointapp.Activate

    Application.CutCopyMode = False

End Sub

1 Ответ

0 голосов
/ 25 октября 2018

Вы можете сделать это с помощью другой процедуры, как показано ниже.Таким образом, вам нужно продублировать только одну строку для каждой копии слайда.

Также обратите внимание, что ваша обработка ошибок была тихой.Это плохая идея, потому что если возникает ошибка, вы просто игнорируете ее и никогда не заметите.Также следующий код не будет работать должным образом.Я тоже это изменил. 

Sub excelrangetopowerpoint_month()
    Dim powerpointapp As Object
    Set powerpointapp = CreateObject("powerpoint.application")

    Dim destinationPPT As String
    destinationPPT = ("C:\Users\OLX-Admin\Dropbox (Corporate Finance)\Naspers Monthly Reporting\Prep for call\From teams\FY2019\OLX Group Monthly Report_Sep'18_Macro.pptx")

    On Error GoTo ERR_PPOPEN
    Dim mypresentation As Object
    Set mypresentation = powerpointapp.Presentations.Open(destinationPPT)
    On Error GoTo 0

    Application.ScreenUpdating = False

    PasteToSlide mypresentation.Slides(1), Worksheets("objectives").Range("m1")
    'duplicate this line for all slides/ranges
    'PasteToSlide mypresentation.Slides(2), Worksheets("objectives").Range("m2")

    powerpointapp.Visible = True
    powerpointapp.Activate

    Application.CutCopyMode = False

ERR_PPOPEN:
    Application.ScreenUpdating = True 'don't forget to turn it on!
    If Err.Number <> 0 Then
        MsgBox "Failed to open " & destinationPPT, vbCritical
    End If
End Sub


Private Sub PasteToSlide(mySlide As Object, rng As Range)
    rng.Copy
    mySlide.Shapes.PasteSpecial DataType:=2 '2 = enhanced metafile

    Dim myShape As Object
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

    myShape.Left = 278
    myShape.Top = 175
End Sub
...