宏复制粘贴多个Excel范围在PPT中

whhtz7ly 于 2022-12-24 发布在其他

关注(0)|答案(1)|浏览(200)

我终于能够创建这个宏，它从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

excel

来源：https://stackoverflow.com/questions/52985306/macro-to-copy-paste-multiple-excel-ranges-in-ppt

1条答案

按热度按时间

q8l4jmvw1#

你可以用下面的方法来做，所以你只需要为每张幻灯片复制一行。
还要注意你的错误处理是无声的。这是一个坏主意，因为如果一个错误发生了，你只是忽略它，你永远不会注意到。而且下面的代码将不能正常工作。我也改变了。

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

赞(0）回复(0）举报 2022-12-24

我来回答

宏复制粘贴多个Excel范围在PPT中

1条答案

相关问题

热门标签

最新问答