Search code examples
excelvbapowerpoint

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

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).

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.

enter image description here

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
Solution

  • Please, use the next code:

    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