将命名范围复制到PPT的代码，其中命名范围是变量

Question

我有一个工作代码，将从excel上的特定工作表复制命名范围，然后将它们粘贴到powerpoint上的特定工作表。然而，它并没有完全按照我需要的方式工作。

主要问题是，根据我的工作簿中的数据，我可以有1到20个命名范围，所以如果我列出所有命名范围，那么我在这些命名范围不存在的行上得到一个错误。

我使用的代码是:

Sub copytablestoppt()
Dim powerpointapp As Object
Set powerpointapp = CreateObject("powerpoint.application")
Dim destinationPPT As String
destinationPPT = ("J:xxxCPA1.ppt")
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(3), Worksheets("Start").Range("DataP")
PasteToSlide mypresentation.Slides(52), Worksheets("Start").Range("IMEI")
PasteToSlide mypresentation.Slides(4), Worksheets("Top Cell IDs & Top Contacts").Range("TopCellIDs1")
powerpointapp.Visible = True
powerpointapp.Activate
Application.CutCopyMode = False
ERR_PPOPEN:
Application.ScreenUpdating = True
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
Dim myShape As Object
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.Left = 278
myShape.Top = 175
End Sub

当我的范围不存在时，有人有任何想法如何解决错误吗?

Answer 1

在复制前检查指定的范围是否存在。如果存在，则只复制它。

Dim rng As Range
On Error Resume Next
Set rng = Worksheets("Start").Range("DataP")
On Error GoTo 0
If Not rng Is Nothing Then
PasteToSlide mypresentation.Slides(3), Worksheets("Start").Range("DataP")
End If

重要提示:如果您计划使用上述方法，那么始终确保从第二个命名范围开始添加这一行。

Set rng = Nothing '<~~~ 
On Error Resume Next
Set rng = Worksheets("Start").Range("IMEI")
On Error GoTo 0