CODEWITHSUNDEEP
excelvbapowerpoint
user1883984
user1883984

Reputation: 87

How to position an Excel range on a PowerPoint slide?

I adapted the following code to my requirements, with the exception of slide positioning. It places the range in a different location on each slide.

I'm trying to place the object a set distance from the left hand side and top of the slide.

Sub copiSylwadau()

'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 MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long

'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(5, 7, 9, 11, 13, 15, 17, 18, 20, 22, 24, 26, 27, 28, 31)

'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet4.Range("A1:A12"), Sheet9.Range("A1:A12"), Sheet10.Range("A1:A12"), Sheet11.Range("A1:A12"), Sheet12.Range("A1:A12"), Sheet13.Range("A1:A12"), Sheet14.Range("A1:A12"), Sheet15.Range("A1:A12"), Sheet16.Range("A1:A12"), Sheet17.Range("A1:A12"), Sheet18.Range("A1:A12"), Sheet19.Range("A1:A12"), Sheet20.Range("A1:A12"), Sheet21.Range("A1:A12"), Sheet22.Range("A1:A12"))

'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.Paste
    Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange
    On Error GoTo 0

    'Center Object
    With myPresentation.PageSetup
        shp.Left = 20
        shp.Top = 40
        shp.Width = 679
    End With
Next x

'Transfer Complete
Application.CutCopyMode = False
ThisWorkbook.Activate
MsgBox "Cyflwyniad PowerPoint wedi eu greu!"

End Sub

Additionally, I've tried numerous ways to set the font and size of the text in the range being copied in. For example, tried adding the code below the myPresentation.PageSetup command, which was not recognised.

Shp.TextRange.Font.Size = 14
Shp.TextRange.Font.Name = "Arial"

Upvotes: 1

Views: 983

Answers (2)

mooseman
mooseman

Reputation: 2017

Since you just paste the range from Excel to Powerpoint it is being pasted as a table and you need to format it that way.

     Dim lRow As Long
     Dim lCol As Long
     Dim oTbl As Table

        Set oTbl = shp.Table
            For lRow = 1 To oTbl.Rows.Count
                For lCol = 1 To oTbl.Columns.Count
                    With oTbl.Cell(lRow, lCol).Shape.TextFrame.TextRange
                        .Font.Name = "Arial"
                        .Font.Size = 14
                    End With
                Next
            Next

Upvotes: 1

Steve Rindsberg
Steve Rindsberg

Reputation: 14809

Try it like so: PageSetup sets the SLIDE size, not the position of shapes on the slide; you don't need to mess with that.

'Paste to PowerPoint and position
  On Error Resume Next
    Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.Paste
    Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange

  'Center Object
    shp.Left = 20
    shp.Top = 40
    shp.Width = 679

Upvotes: 1

Related Questions