VBA: Populate array from range with range coordinates?

amzraven

New Member
Joined
Mar 18, 2022
Messages
2
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
  2. Web
Hello,

I'm working on a franken-code from TheSpreadheetGuru's excellent multi-range to multi ppt slide guide at:

My issue is, I need to populate the MyRangeArray with data in a table (Sheet17, table name S"lidesA")

VBA Code:
'List of Excel Ranges to Copy from
    MyRangeArray = Array(Sheet23.Range("A5:B29"), Sheet23.Range("E5:F30"), Sheet23.Range("S5:T30"), Sheet23.Range("N5:O11"), Sheet23.Range("X5:Y11"), Sheet22.Range("A5:B27"), Sheet22.Range("E5:F26"), Sheet22.Range("I5:J27"), Sheet18.Range("A5:B32"), Sheet18.Range("E5:F25"), Sheet16.Range("A5:B23"))

I've tried several variations of populating from a delimited string, creating a tempArray and basically every option listed in Dynamically Populating VBA Array Variables To Store Lists of Data — TheSpreadsheetGuru which all seem to run well to a print, but when I try to add them to my full code, give me an error 9 Subscript out of range.

My end goal:
This sheet (when all the bugs are worked out) will be sent to a non tech-savvy user who I do not want to have to instruct in messing with the code to change the arrays every month. I would like the MyRangeArray to auto-populate, either from a single cell with a delimited value, or from a table- whichever is easier.

The number of entries does not vary, but the ranges in the array change in depth.

Any guidance would be greatly appreciated!
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
My full franken-code:

VBA Code:
Sub PasteSnipSlides()

'PURPOSE: Copy Excel Ranges and Paste them into the Active PowerPoint presentation slides
'SOURCE: www.TheSpreadsheetGuru.com

Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArrayA As Variant
Dim MyRangeArrayA As Variant
Dim MySlideArrayB As Variant
Dim MyRangeArrayB As Variant
Dim MySlideArrayTPB As Variant
Dim MyRangeArrayTPB As Variant
Dim x As Long


'-------This is where I want to have Dynamic ranges storing the multiple arrays------
'Side A Coordinates:
'List of PPT Slides to Paste to
  MySlideArrayA = Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22)

'Ranges to Copy from
    MyRangeArrayA = Array(Sheet23.Range("A5:B29"), Sheet23.Range("E5:F30"), Sheet23.Range("S5:T30"), Sheet23.Range("N5:O12"), Sheet23.Range("X5:Y12"), Sheet22.Range("A5:B27"), Sheet22.Range("E5:F26"), Sheet22.Range("I5:J27"), Sheet18.Range("A5:B32"), Sheet18.Range("E5:F25"), Sheet16.Range("A5:B23"), Sheet16.Range("E5:F29"), Sheet24.Range("A5:B27"), Sheet16.Range("I5:J33"), Sheet24.Range("E5:F32"), Sheet16.Range("S5:T33"), Sheet24.Range("I5:J32"), Sheet16.Range("X5:Y26"), Sheet24.Range("N5:O25"), Sheet16.Range("AC5:AD33"), Sheet24.Range("S5:U32"))

'Side B Coordinates:
    MySlideArrayB = Array(3, 4)
'Ranges to Copy from
    MyRangeArrayB = Array(Sheet23.Range("I5:J24"), Sheet23.Range("AC5:AD26"))
 
'TPB Rates PPT Slides to Paste to
  MySlideArrayTPB = Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21)

'Ranges to Copy from
    MyRangeArrayTPB = Array(Sheet4.Range("N2:O7"), Sheet4.Range("N2:O7"), Sheet4.Range("N2:O7"), Sheet4.Range("S2:T6"), Sheet4.Range("S2:T6"), Sheet4.Range("X2:Y3"), Sheet4.Range("X2:Y3"), Sheet4.Range("X2:Y3"), Sheet4.Range("AC2:AD3"), Sheet4.Range("AC2:AD3"), Sheet4.Range("AH2:AI8"), Sheet4.Range("AH2:AI8"), Sheet4.Range("AM2:AN8"), Sheet4.Range("AH2:AI8"), Sheet4.Range("AM2:AN8"), Sheet4.Range("AH2:AI8"), Sheet4.Range("AM2:AN8"), Sheet4.Range("AH2:AI8"), Sheet4.Range("AM2:AN8"), Sheet4.Range("AH2:AI8"))



'Create an Instance of PowerPoint
  On Error Resume Next
   
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
   
    'Clear the error between errors
      Err.Clear

    'If PowerPoint is not already open then Exit
      If PowerPointApp Is Nothing Then
        MsgBox "PowerPoint Presentation is not open, aborting."
        Exit Sub
      End If
   
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If

  On Error GoTo 0
 
'Make PowerPoint Visible and Active
  PowerPointApp.ActiveWindow.Panes(2).Activate
   
'Create a New Presentation
  Set myPresentation = PowerPointApp.ActivePresentation

'>>>>>>>>>>Left side section<<<<<<<<<<<<<<<<

'Loop through Array data
  For x = LBound(MySlideArrayA) To UBound(MySlideArrayA)
    'Copy Excel Range
        MyRangeArrayA(x).Copy
   
    'Paste to PowerPoint and position
      On Error Resume Next
        Set shp = myPresentation.Slides(MySlideArrayA(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
        Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
      DoEvents
      On Error GoTo 0
   
    'Center Object
      With myPresentation.PageSetup
        shp.Left = 30
        shp.Top = 90
      End With
     
  Next x

'>>>>>>>>>>Right Side section<<<<<<<<<<<<<<<<

'Loop through Array data
  For x = LBound(MySlideArrayB) To UBound(MySlideArrayB)
    'Copy Excel Range
        MyRangeArrayB(x).Copy
   
    'Paste to PowerPoint and position
      On Error Resume Next
        Set shp = myPresentation.Slides(MySlideArrayB(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
        Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
      DoEvents
      On Error GoTo 0
   
    'Center Object
      With myPresentation.PageSetup
        shp.Left = 350
        shp.Top = 120
      End With
     
  Next x
 
'>>>>>>>>>>TPBsection<<<<<<<<<<<<<<<<

 'Loop through Array data
  For x = LBound(MySlideArrayTPB) To UBound(MySlideArrayTPB)
    'Copy Excel Range
        MyRangeArrayTPB(x).Copy
   
    'Paste to PowerPoint and position
      On Error Resume Next
        Set shp = myPresentation.Slides(MySlideArrayTPB(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
        Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
      DoEvents
      On Error GoTo 0
   
    'Center Object
      With myPresentation.PageSetup
        shp.Left = 590
        shp.Top = 5
      End With
     
  Next x

'Transfer Complete
  Application.CutCopyMode = False
  ThisWorkbook.Activate
  MsgBox "Snippets Copied!"

End Sub
 
Upvote 0

Forum statistics

Threads
1,223,884
Messages
6,175,175
Members
452,615
Latest member
bogeys2birdies

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top