Excel to PPT VBA Positioning - Despite other answers... no success Please help

certainlyfrustrated

New Member
Joined
Apr 22, 2021
Messages
1
Office Version
  1. 365
Platform
  1. Windows
Hi there,

I have combed many of the answers that beat around this, even on other forums, but none seem to work for me. I am very much a novice or less with VBA and trying to make this work as saves an enormous amount of time. My issue is that the slides have varying positions and even that aside, I still haven't been able to get the slide to properly position the charts:

Sheet 13 needs special position of 1.14 x 1.4
All other Slide Position 0.92 x 1.32
GraphSize 5.26, 8.6 with position 3.82 and 1.36

My current VBA code is below but does not yet even touch upon the sizing for the Graphs or Sheet 13. Any help here is VERY much appreciated as I have been touching on this on and off for years with no success and been manually moving... Code is below. Thank you so much for the help if any!
VBA Code:
Sub PasteMultipleSlides()

'PURPOSE: Data Transfer from Excel to PPT

Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long
Dim PPApp  As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide

'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

'List of PPT Slides to Paste to 
  MySlideArray = Array(9, 10, 11, 12, 13, 5, 14, 15, 8, 7, 8, 22, 22, 22, 18, 16, 16, 17, 17, 1)

'List of Excel Ranges to Copy from
  MyRangeArray = Array(Sheet1.Range("A1:B9"), Sheet2.Range("A1:B7"), Sheet3.Range("A1:B7"), _
       Sheet4.Range("A1:B8"), Sheet5.Range("A1:B10"), Sheet7.Range("A1:B8"), Sheet6.Range("A1:B8"), _
       Sheet8.Range("A1:C8"), Sheet1.Range("B8"), Sheet7.Range("B3"), Sheet7.Range("A1:B7"), _
       Sheet9.Range("AA3"), Sheet9.Range("Z4"), Sheet9.Range("Z13"), Sheet13.Range("A1:K20"), _
       Sheet9.Range("Z4"), Sheet9.Range("AA4"), Sheet9.Range("Z13"), Sheet9.Range("AA16"), Sheet13.Range("A27"))
    
'Loop through Array data
  For x = LBound(MySlideArray) To UBound(MySlideArray)
  
    'Copy Excel Range
        MyRangeArray(x).Copy
    
    'Paste to PowerPoint and position
      On Error Resume Next
        Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=10)
   shp.Left = 1.36 * 72
    shp.Top = 0.92 * 72
      On Error GoTo 0

      
  Next x
  
        ' Reference existing instance of PowerPoint
        Set PPApp = GetObject(, "Powerpoint.Application")
        ' Reference active presentation
        Set PPPres = PPApp.ActivePresentation
  
'Copy "Chart 10" to Slide # 16 
        ' Copy "Chart 10"
            Sheets("Chart 1 OS").Select
    ActiveChart.ChartArea.Select
    ActiveChart.ChartArea.Copy
        ' Paste chart  to Slide # 16
        With PPPres.Slides(16).Shapes.Paste
            ' Align pasted chart
            .Align msoAlignCenters, True
            .Align msoAlignMiddles, True
        End With
        
'Copy "Chart 11" to Slide # 17
        ' Copy "Chart 11"
            Sheets("Chart 2 SH").Select
    ActiveChart.ChartArea.Select
    ActiveChart.ChartArea.Copy
        ' Paste chart  to Slide # 17
        With PPPres.Slides(17).Shapes.Paste
            ' Align pasted chart
            .Align msoAlignCenters, True
            .Align msoAlignMiddles, True
        End With
        

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

End Sub
 
Last edited by a moderator:

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result

Forum statistics

Threads
1,141,715
Messages
5,708,021
Members
421,540
Latest member
quocbinh

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
Top