I try to apply a powerpoint table style from vba excel but i had an issue, someone can help to try how apply a style in table object ?
My macro work fine expect the style part ....
this code go to error 400 -- execution error --> Method 'table' of the object 'Shape' has failed
Set otbl = PPT_Shape.Table
This is a sample of my code here below
Sub ExcelRangeToPowerPoint()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim sPath As String
Dim project As String
Dim otbl As TableObject
'Set Title
project = Feuil1.Cells("2", "C")
'Set the template
sPath = "C:\Users\E049XXXX\OneDrive - XXX\XXX\"
'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("A1:N34")
'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 open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'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
'Optimize Code
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
'Add a slide to the Presentation
PowerPointApp.ActivePresentation.ApplyTemplate "C:\Users\E049XXXX\OneDrive - XXXX\Documents\XXXXX.thmx"
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=0 '0 = ppPasteDefault
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 66
myShape.Top = 152
'Add Title
Set myTitle = mySlide.Shapes.Title
myTitle.TextFrame.TextRange.Characters.Text = project
'Add style
Set PPT_Shape = myShape
Set otbl = PPT_Shape.Table
With otbl
.ApplyStyle "{C083E6E3-FA7D-4D7B-A595-EF9225AFEA82}", True
End With
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
I have got the below code to copy the image from range of cells of excel to PPT, but the image pasted on the PPT does is of different dimensions.
Can someone tell me how can I fix size of the image when pasted in PPT.
I am pasting my code below for your reference.
Private Sub CommandButton1_Click()
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
'Unhiding the sheets
Worksheets("Sheet4").Visible = xlSheetVisible
'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("A1:C12")
'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 open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'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
'Optimize Code
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Mupltiple Slides
'List of PPT Slides to Paste to
MySlideArray = Array(1, 2, 3)
'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet2.Range("A1:AB71"), Sheet1.Range("A1:AL70"), Sheet5.Range("A1:AE56"))
'Loop through Array data
For x = LBound(MySlideArray) To UBound(MySlideArray)
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 12) '12 = ppLayoutBlank 'https://learn.microsoft.com/en-us/office/vba/api/powerpoint.ppslidelayout
'Copy Excel Range
'rng.Copy
MyRangeArray(x).Copy
Application.Wait (Now + TimeValue("0:00:03"))
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.count)
'Set position:
myShape.Left = 0
myShape.Top = 0
Next x
'Message Box
MsgBox ("Please is ready !!")
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Clear The Clipboard
Application.CutCopyMode = False
'Hiding the sheets back
Worksheets("Sheet4").Visible = xlSheetHidden
End Sub
I am trying to prepare a presentation from Excel. As of now VBA code is preparing "n number of "presentations as per no of times Loop runs. I want Code to generate just 1 presentation with all slides combined. Fist Macro "Addnumber" is run, which run Macro "ExcelRangeToPowerPoint". Its Macro "ExcelRangeToPowerPoint"which need to add slides for every loop of Macro "Addnumber"
Please Support
Sub AddNumber()
Dim Ws As Worksheet
Dim rngSel As Range
Dim rng As Range
Dim Num As Double
Dim i As Long
Dim j As Long
Dim lAreas As Long
Dim lRows As Long
Dim lCols As Long
Dim Arr() As Variant
Set rngSel = Worksheets("Sheet1").Range("A5:A30")
Do Until Range("A30") = Range("A3")
Num = 26
For Each rng In rngSel.Areas
If rng.Count = 1 Then
rng = rng + Num
Else
lRows = rng.Rows.Count
lCols = rng.Columns.Count
Arr = rng
For i = 1 To lRows
For j = 1 To lCols
Arr(i, j) = Arr(i, j) + Num
Next j
Next i
rng.Value = Arr
End If
Call ExcelRangeToPowerPoint
Next rng
Loop
End Sub
Sub ExcelRangeToPowerPoint()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
Dim rng As Range
Dim rng2 As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim mySize As PageSetup
Dim Addtitle As Shape
Dim DateT As String
'Copy Range from Excel
Set rng = Worksheets("Sheet1").Range("E2:M30")
Set rng2 = Worksheets("Sheet1").Range("F2")
Set rng3 = Worksheets("Sheet1").Range("B3")
'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 open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'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
'Optimize Code
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11)
'11 = ppLayoutTitleOnly
'Change Theme and Layout
mySlide.ApplyTheme "C:\Users\davinder.sond\AppData\Roaming\Microsoft\Templates\Document Themes\DefaultTheme.thmx"
myPresentation.PageSetup.SlideSize = 3
myPresentation.Slides(1).Shapes.Title.TextFrame.TextRange.Text = rng2
myPresentation.Slides(1).Shapes.Title.Left = 59
myPresentation.Slides(1).Shapes.Title.Top = 10
myPresentation.Slides(1).Shapes.Title.Height = 30
myPresentation.Slides(1).Shapes.Title.Width = 673
With myPresentation.Slides(1).Shapes.Title
With .TextFrame.TextRange.Font
.Size = 24
.Name = "Arial"
.Bold = True
.Color.RGB = RGB(255, 255, 255)
End With
End With
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.LockAspectRatio = 0
myShape.Left = 12
myShape.Top = 55
myShape.Height = 475
myShape.Width = 756
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
DateT = Format("h:mm:ss")
'Clear The Clipboard
Application.CutCopyMode = False
myPresentation.SaveAs "C:\Project Control CCJV\ExperimentsPunch\" & rng3 & ".pptm"
PowerPointApp.Quit
End Sub
You are creating a new presentation everytime you call Set myPresentation = PowerPointApp.Presentations.Add within ExcelRangeToPowerPoint().
You can either try to open/close the Presentation outside of ExcelRangeToPowerPoint() and add a parameter to the function like ExcelRangeToPowerPoint(myPresentationObject) then you can simple add the slides there
or
you call the function AddNumber() within ExcelRangeToPowerPoint() of coarse the you need to loop there...
e.g.
Sub ExcelRangeToPowerPoint()
' some preparative code
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11)
For Each rng in rngSel.Areas
'Filling the presentation one slide at a time
AddSlide(rng)
Next
'Clear The Clipboard
Application.CutCopyMode = False
myPresentation.SaveAs "C:\Project Control CCJV\ExperimentsPunch\" & rng3 &
".pptm"
PowerPointApp.Quit
'some more code
End Sub
I have VBA code that contains the range Excel to PPT. So my question is how can I set a dynamic range instead of giving the array values here.
the example below code want same in dynamic:-
MySlideArray = Array(5, 7, 9, 11, 13, 15, 17, 18, 20, 22, 24, 26, 27, 28, 31)
MyRangeArray = Array(Sheet4.Range("A10:AS69"), Sheet9.Range("Q10:AH69"), Sheet10.Range("A1:AX65"), 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"))
I have a Report card that contains all the sheets with Excel range, so when I refer the array it should be capture the Report card Range
Ex
How to build a dynamic range?
ub 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
Dim MyArray As Variant
Dim iCounter As Integer
'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
'MyArray = Worksheets("control").Range("rng")
'MsgBox "MyArray"
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
'If iCounter = iCounter < 2 Then
'If rCell And Not rCell.Offset(0, 2) Then
'copy slide template
'myPresentation.Slides(4).Copy
'Set obSlide = myPresentation.Slides.Paste(Index:=iCounter)
' iCounter = iCounter
' End If
'Paste to PowerPoint and position
On Error Resume Next
Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=True)
Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange
Set MySlideArray = myPresentation.Add(myPresentation.Count + 1)
On Error GoTo 0
'Center Object
With myPresentation.PageSetup
shp.Left = 20
shp.Top = 70
shp.Width = 670
'shp.Height = ppAutoSizeShapeToFitText
End With
Next x
'Transfer Complete
Application.CutCopyMode = False
ThisWorkbook.Activate
MsgBox "Cyflwyniad PowerPoint wedi eu greu!"
End Sub
Suggest you create named ranges directly then refer to those in your code.
Example: use the name "Sheet4Range" to name Sheet4.Range("A10:AS69")
In your code:
Sheet4.Range("Sheet4Range")
You can make the definition of the actual Sheet4Range range a Dynamic Named Range (DNR). There are many resources to learn how to construct a DNR. Here's one: https://www.excel-easy.com/examples/dynamic-named-range.html
So I am trying to paste a column into powerpoint slide notes but it only grabs one cell and pastes it into the first slide and will not go to the next slide and paste the next cell into the notes of the 2nd slide.
Sub Notes()
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim PPTShape As PowerPoint.Shape
Dim strNotes As String
' Amended Dim Sh As Shape to...
Dim Sh As PowerPoint.Shape
'launch powerpoint application
Set PPTApp = New PowerPoint.Application
PPTApp.Activate
'open powerpoint presentation for macmahon off the intranet
Set PPTPres = PPTApp.Presentations.Open("C:\Users)
Sheets("Raw Data").Select
Range("M2:M26").Select
Set PPTSlide = PPTPres.Slides(1)
On Error GoTo errHandler
Do While ActiveCell.Value <> ""
ActiveCell.Copy
With PPTSlide
If PPTSlide.NotesPage.Shapes.Count = 0 Then 'If no shapes to take Notes then add a shape first
PPTSlide.NotesPage.Shapes.AddShape msoShapeRectangle, 0, 0, 0, 0
Sh = PPTSlide.NotesPage.Shapes(1)
'Code change here - did not recognize Sh.TextFrame.TextRange.Text.Paste
'So, I set the object text to value of the active cell and seemed to do the trick
Sh.TextFrame.TextRange.Text = ActiveCell.Value
Else 'has shapes, so see if they take text
For Each Sh In PPTSlide.NotesPage.Shapes
If Sh.HasTextFrame Then
'Code change here - did not recognize Sh.TextFrame.TextRange.Text.Paste
'So, I set the object text to value of the active cell and seemed to do the trick
Sh.TextFrame.TextRange.Text = ActiveCell.Value
End If
Next Sh
End If
End With
Set PPTSlide = PPTPres.Slides.Add(PPTPres.Slides.Count + 1, ppLayoutText)
ActiveCell.Offset(1, 0).Select
Loop
Exit Sub
errHandler:
MsgBox Err.Number & vbTab & Err.Description, vbCritical, "Error"
End Sub
You are setting a fixed reference to slide 1 in this line:
Set PPTSlide = PPTPres.Slides(1)
Instead of that, wrap the code to copy and paste the cell content in a For...Next loop which loops through your desired slides. For example, to loop through all slides in the presentation:
For Each PPTSlide In PPTPres.Slides
With PPTSlide
' Do the things you need to do on this slide
End With
Next
Or manage a pre-defined range of slides:
Dim lSlideIndex As Long
For lSlideIndex = 2 to 5 ' Process slides 2 to 5
With PPTPres.Slides(lSlideIndex)
' Do the things you need to do on this slide
End With
Next