创建循环以将多个 Sheet 范围作为图片粘贴到 Power Point

Creating a Loop to Paste Multiple Sheet Ranges to Power Point as Pictures

我一直在尝试修改下面的代码,但在 ReDim Preserve arr(k - 1).

行收到错误 Script out of range

代码取 Status of Col"E" 如果是 = Include 那么其对应的工作表范围将作为图片粘贴到 Power Point。

但这不起作用,我们将不胜感激您的帮助。

Sub SelectSheets_Ranges()
  Dim sh As Worksheet, lastR As Long, rng As Range, arr, arrSplit, i As Long, k As Long
  
  Set sh = ActiveSheet
  lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
  
  ReDim arr(lastR - 1)
  For i = 5 To lastR
        If sh.Range("E" & i).Value = "Include" Then
            arr(k) = sh.Range("C" & i).Value & "|" & sh.Range("D" & i).Value: k = k + 1
        End If
  Next i
  ReDim Preserve arr(k - 1)
  For i = 0 To UBound(arr)
        arrSplit = Split(arr(i), "|")
        Set rng = Worksheets(arrSplit(0)).Range(arrSplit(1))

''''
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
On Error Resume Next

      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
      Err.Clear
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If

  On Error GoTo 0
  Application.ScreenUpdating = False
  Set myPresentation = PowerPointApp.Presentations.Add
  Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
  rng.Copy

  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
      myShape.Left = 66
      myShape.Top = 152
  PowerPointApp.Visible = True
  PowerPointApp.Activate
  Application.CutCopyMode = False
  '''''''''
  
Next
End Sub

请使用下一个代码:

Sub SelectSheets_Ranges()
  Dim sh As Worksheet, lastR As Long, rng As Range, arr, arrSplit, i As Long, k As Long
  Dim PowerPointApp As Object, myPresentation As Object, mySlide As Object, myShape As Object
  
    On Error Resume Next
      Set PowerPointApp = GetObject(Class:="PowerPoint.Application")
      err.Clear
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(Class:="PowerPoint.Application")
      If err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If
   On Error GoTo 0
  Set myPresentation = PowerPointApp.Presentations.Add 
  Set sh = ActiveSheet
  lastR = sh.Range("C" & sh.rows.count).End(xlUp).row
  
  ReDim arr(lastR - 1)
  For i = 5 To lastR
        If sh.Range("E" & i).value = "Include" Then
            arr(k) = sh.Range("C" & i).value & "|" & sh.Range("D" & i).value: k = k + 1
        End If
  Next i
  ReDim Preserve arr(k - 1)
  For i = 0 To UBound(arr)
        arrSplit = Split(arr(i), "|")
        Set rng = Worksheets(arrSplit(0)).Range(arrSplit(1))

          Application.ScreenUpdating = False          
          Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
          rng.Copy
        
          mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
          Set myShape = mySlide.Shapes(mySlide.Shapes.count)
              myShape.left = 66
              myShape.top = 152
          PowerPointApp.Visible = True
          PowerPointApp.Activate
          Application.CutCopyMode = False
 Next
End Sub