Excel to PowerPoint Paste with Keep Source Formatting

kpmsivaprakasam2003

New Member
Joined
Jan 28, 2020
Messages
14
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2013
  5. 2011
  6. 2010
  7. 2007
Platform
  1. Windows
Hi i am using the excel 2013
I activated the excel and PowerPoint with 2 nos empty slides

Sheets "1" and "2" data range copy and paste to PowerPoint

this code paste with image, I need Paste with "Keep Source Formatting"

VBA Code below here:


Sub PasteMultipleSlides()
'PURPOSE: Copy Excel Ranges and Paste them into the Active PowerPoint presentation slides

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(1, 2)

'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheets("1").Range("B1:E12"), Sheets("2").Range("B1:M11"))
'MyRangeArray = Array(Sheet1.Range("A1:C10"), Sheet4.Range("A1:C10"), _
Sheet3.Range("A1:C10"), Sheet2.Range("A1:C10"), Sheet5.Range("A1:C10"))

'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:=2) 'Excel 2007-2010
On Error GoTo 0


'Center Object
With myPresentation.PageSetup
shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
End With

Next x

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

End Sub



Please modification this code
thanks for your help
 

Attachments

  • keep-source-formatting.png
    keep-source-formatting.png
    2.4 KB · Views: 29

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
cross posted

the solution:

VBA Code:
Sub PasteMultipleSlides()
Dim mypres As Object, ppapp As Object, shp As Object, sa, ra, x%, ns%, i%
Set ppapp = GetObject(Class:="PowerPoint.Application")
Err.Clear
If ppapp Is Nothing Then
    MsgBox "PowerPoint Presentation is not open, aborting."
    Exit Sub
End If
If Err.Number = 429 Then
    MsgBox "PowerPoint could not be found, aborting."
    Exit Sub
End If
On Error GoTo 0
ppapp.ActiveWindow.Panes(2).Activate
Set mypres = ppapp.ActivePresentation
sa = Array(1, 2)
ra = Array(Sheets("inplay").Range("B1:E12"), Sheets("test").[b1:e11])
For x = LBound(sa) To UBound(sa)
    ra(x).Copy
    mypres.Windows(1).View.GotoSlide sa(x)
    ns = mypres.Slides(sa(x)).Shapes.Count
    ppapp.CommandBars.ExecuteMso ("PasteSourceFormatting")
    DoEvents
    For i = 1 To mypres.Slides(sa(x)).Shapes.Count
        MsgBox mypres.Slides(sa(x)).Shapes(i).name
    Next
    Set shp = mypres.Slides(sa(x)).Shapes(ns + 1)
    With mypres.PageSetup
        shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
        shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
    End With
Next
Application.CutCopyMode = False
ThisWorkbook.Activate
MsgBox "Complete!"
End Sub
 
Upvote 0

Forum statistics

Threads
1,224,852
Messages
6,181,397
Members
453,034
Latest member
mikdadhussain

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