创建循环以将多个工作表范围粘贴到 Power Point 作为图片 [英] Creating a Loop to Paste Multiple Sheet Ranges to Power Point as Pictures

问题描述

我一直在尝试修改下面的代码，但在 ReDim Preserve arr(k - 1) 行上收到错误 Script out of range.

I have been trying to modify this below code but receiving an error Script out of range on the line ReDim Preserve arr(k - 1).

代码取ColE"的状态 如果它是 = Include 那么其相应的工作表范围将作为图片粘贴到 Power Point.

The code is take the Status of Col"E" If it is = Include then its corresponding sheets ranges will be pasted as picture to Power Point.

但这不起作用，您的帮助将不胜感激.

But this is not working your help will be highly appreciated.

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

这篇关于创建循环以将多个工作表范围粘贴到 Power Point 作为图片的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！