Pasting Selected Ranges into a PowerPoint Slides

You wanted all the ranges on one slide?

For each range in its own slide and sized to fit width I used this code. I added Early binding so you can change it back or add the reference or just add the line were I set the Range areas and the slide shape's Width. If Height is set 2nd, the width expands over the page width.

If you wanted to include your rectangle shapes this will do it as well. In fact, we could code it to get the area ranges based on rectangular shapes over the ranges.

Sub CreatePPoint()
  'Late Binding
  'Dim pPoint As Object    'PowerPoint.Application
  'Dim pPres As Object     'PowerPoint.Presentation
  'Dim pSlide As Object    'PowerPoint.Slide
  'Dim pShape As Object    'PowerPoint.ShapeRange
  'Dim pAvg As Object      'PowerPoint.Shape
  
  'Early Binding
  'Add Tools > References.. > Microsoft Powerpoint 11.0 Object Library
  Dim pPoint As PowerPoint.Application
  Dim pPres As PowerPoint.Presentation
  Dim pSlide As PowerPoint.Slide
  Dim pShape As PowerPoint.ShapeRange
  Dim pAvg As PowerPoint.Shape
  
  Dim r As Range, ar
  Set r = Range("A2:N20,A23:N39,A42:N58,A61:N77")
  
  'Turn off screen updating
  Application.ScreenUpdating = False

  'Create a new PowerPoint presentation (and application)
  'New PowerPoint.Application
  'Late Binding
  'Set pPoint = CreateObject("PowerPoint.Application")
  'Early Binding
  Set pPoint = New PowerPoint.Application
  
  Set pPres = pPoint.Presentations.Add

  'Loop through each of the items of the page field
  For Each ar In r.Areas
      If pPres.Slides.Count = 0 Then
        Set pSlide = pPres.Slides.Add(1, 12)    'ppLayoutBlank = 12
      Else
        Set pSlide = pPres.Slides.Add(pPres.Slides.Count + 1, _
            12)      'ppLayoutBlank
      End If

      'Copy an image of the chart
      ar.CopyPicture Appearance:=xlPrinter, Format:=xlPicture

      'Paste it in PowerPoint
      Set pShape = pSlide.Shapes.Paste

      'Resize it
      With pShape
        Debug.Print "width", .Width, pPres.PageSetup.SlideWidth
        .Left = 10
        .Top = 10
        .Height = pPres.PageSetup.SlideHeight - 20
        .Width = pPres.PageSetup.SlideWidth - 20
        '.ScaleWidth 1, msoFalse, msoScaleFromTopLeft 'Was 1
        '.ScaleHeight 1, msoFalse, msoScaleFromBottomRight  'Was 0.94
      End With
  Next ar

  'Restore screen updating
  Application.ScreenUpdating = True

  'Activate and display PowerPoint
  pPoint.Visible = True
  pPoint.ActiveWindow.ViewType = 1    'ppViewSlide = 1
  pPoint.Activate

  'Destroy the variables
  Set pShape = Nothing
  Set pSlide = Nothing
  Set pPres = Nothing
  Set pPoint = Nothing
End Sub

I hope I did not confuse you. Initially, I did ask for you to have all of the ranges be on individuals slides. I just wanted to have the option to also fit all of the ranges on one slide and size it to fit on the PowerPoint.

When I copy and paste the new code into the previous Excel attachment, I get an error. The code does not work.

Please try your code in the previous spreadsheet and let me know what happens on your end.

Thanks

Thanks for the reply. I will try your first suggestion and "unmerged" the cells. That is a good start. I will let you know what happens.

Stay tune.

Thank you Kenneth Hobson for all the hard work you put into this.

I finally have gotten around to playing with your code and I was able to get all of the ranges to fit on the PowerPoint Slide. With excellent readability. It looks great!!

Here is how I revised your code:

Sub CreatePPoint()
  Dim pPoint As Object    'PowerPoint.Application
  Dim pPres As Object     'PowerPoint.Presentation
  Dim pSlide As Object    'PowerPoint.Slide
  Dim pShape As Object    'PowerPoint.ShapeRange
  Dim pAvg As Object      'PowerPoint.Shape

  Dim Cht As Chart
  Dim Pivot As PivotTable
  Dim PItem As PivotItem
  Dim PivotData As Range
  Dim Avg As Double
  Dim r As Range, ar
  Set r = Range("A2:q88")
  'Turn off screen updating
  Application.ScreenUpdating = False

  'Create a new PowerPoint presentation (and application)
  'New PowerPoint.Application
  Set pPoint = CreateObject("PowerPoint.Application")
  
  Set pPres = pPoint.Presentations.Add

  'Loop through each of the items of the page field
  For Each ar In r.Areas
      If pPres.Slides.Count = 0 Then
        Set pSlide = pPres.Slides.Add(1, 12)    'ppLayoutBlank = 12
      Else
        Set pSlide = pPres.Slides.Add(pPres.Slides.Count + 1, _
            12)      'ppLayoutBlank
      End If

      'Copy an image of the chart
      ar.CopyPicture Appearance:=xlPrinter, Format:=xlPicture

      'Paste it in PowerPoint
      Set pShape = pSlide.Shapes.Paste

      'Resize it
      With pShape
        .ScaleWidth 0.8, msoFalse, msoScaleFromTopLeft
        .ScaleHeight 0.5, msoFalse, msoScaleFromBottomRight
        .Left = 50
        .Top = 75
    
      End With
  Next ar

  'Restore screen updating
  Application.ScreenUpdating = True

  'Activate and display PowerPoint
  pPoint.Visible = True
  pPoint.ActiveWindow.ViewType = 1    'ppViewSlide = 1
  pPoint.Activate

  'Destroy the variables
  Set pShape = Nothing
  Set pSlide = Nothing
  Set pPres = Nothing
  Set pPoint = Nothing
End Sub