[英]Macro to copy paste multiple excel ranges in PPT
我終於能夠創建這個宏,它從 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
您可以使用如下所示的另一個程序來完成。 因此,您只需為每個副本復制一行到幻燈片。
另請注意,您的錯誤處理是靜默的。 這是一個壞主意,因為如果發生錯誤,您只需忽略它,您將永遠不會注意到。 此外,以下代碼將無法正常工作。 我也是這樣改的。
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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.