PDA

View Full Version : [SOLVED] Copy Excel range & paste in PPT as [Pastespecial - M.O. Excel Worksheet(Code) Object]



loveguy1977
08-04-2013, 05:00 PM
Dear Sir,

Below is VBA finally I found after long time of search which is (Copy range from Excel and paste in PPT slide using [Pastespecial - Micorosoft Office Excel Worksheet(Code) Object]) and I am seeking your help please to modify it as follow:

Each range to each page in PPT file (show in cell A1 as file name with full path) A1: E:\Test\aaa.pptx)

Method 1
Range Named Rng1 to Slide No. 1
Range Named Rng2 to Slide No. 2
Range Named Rng3 to Slide No. 3
and so on

Or method2
each VBA for one range then I will make VBA as many as number of ranges I have


Sub export_to_ppt()'In tools Refrence add microsoft outlook
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.slide
Dim SlideCount As Integer
Dim shptbl As Table

Set PPApp = New PowerPoint.Application
PPApp.Visible = True
'create new ppt
Set PPPres = PPApp.Presentations.Add
'count no of slides
SlideCount = PPPres.Slides.Count
'set layout of slide
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutTitleOnly)
'add header
PPSlide.Shapes(1).TextFrame.TextRange.Text = Sheets(1).Range("A1").Value
'format header
With PPSlide.Shapes(1).TextFrame.TextRange.Characters
.Font.Size = 30
.Font.Name = "Arial"
.Font.Color = vbWhite
End With

With PPSlide.Shapes(1)
.Fill.BackColor.RGB = RGB(79, 129, 189)
.Height = 50
End With

Sheets(1).Range("a3:c9").Copy ' copy the range
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex ' activate the slide no
PPApp.ActiveWindow.View.PasteSpecial ppPasteOLEObject, msoFalse ' paste using pastespecial method

Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing

End Sub


Thank you very much

p45cal
08-05-2013, 03:20 AM
In the tweaked code below I have only put the three named ranges onto separate new slides in the new presentation (I'm not sure what you want with regards to putting a file name in A1 (A1 of which sheet? Are the rng1,rng2 each on a different sheet?) How are you determing the file name of the powerpoint file? etc.).
Also note that since you seem to be using a version of MSOffice later than 2003 the named ranges' names ("rng1", "rng2" etc.) actually refer to cell addresses on a sheet, so I renamed the names to "rang1", "rang2" etc.

Sub export_to_ppt2() 'In tools Refrence add microsoft outlook
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.slide
Dim SlideCount As Integer
Dim shptbl As Table

Set PPApp = New PowerPoint.Application
PPApp.Visible = True
'create new ppt
Set PPPres = PPApp.Presentations.Add
For Each Rng In Array("rang1", "rang2", "rang3")
Set PPSlide = PPPres.Slides.Add(PPPres.Slides.Count + 1, ppLayoutTitleOnly)
Range(Rng).Copy ' copy the range
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex ' activate the slide no
PPApp.ActiveWindow.View.PasteSpecial ppPasteOLEObject, msoFalse ' paste using pastespecial method
Next Rng
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub

loveguy1977
08-05-2013, 05:45 AM
Thank you Mr. p45cal

Your vba is ok with me but what about if I wanna copy rang1 to slide no 6

meaning not to use For Each Rng In Array method

Thank you

p45cal
08-05-2013, 07:27 AM
change the line:
For Each Rng In Array("rang1", "rang2", "rang3")
to:
For Each Rng In Array("rang4", "rang2", "rang3", "rang6", "rang5", "rang1")
rang1 will be on the 6th new page (and rang4 on the 1st, rang2 on the 2nd, rang3 on the 3rd, rang6 on the 4th, rang5 on the 5th)

loveguy1977
08-05-2013, 09:25 AM
change the line:
For Each Rng In Array("rang1", "rang2", "rang3")
to:
For Each Rng In Array("rang4", "rang2", "rang3", "rang6", "rang5", "rang1")
rang1 will be on the 6th new page (and rang4 on the 1st, rang2 on the 2nd, rang3 on the 3rd, rang6 on the 4th, rang5 on the 5th)



Thank you but this way I thought for it but it will never help me. Actual example is that I have ppt file content of 25 slides.
On the 5th, 8th, 10th, 14th, 17th, and 23rd slide, the ranges will be copied. The other slides are not changeable (or must modify mannully)

So the array will be like this:
rang1 to slide5
rang2 to slide8
rang3 to slide10
rang4 to slide14
rang5 to slide17
rang6 to slide23


That is why I prefer a method for each range. Then I will make many VBA as I want

loveguy1977
08-05-2013, 01:44 PM
Is there way to copy range2 to slide8. If so, just give me one example of above then i will do for the others
Thank you

p45cal
08-05-2013, 02:00 PM
So you don't want to add a new slide for each range copied.
Assuming you have already got a presentation with the necessarty number of slides in and you've set it to PPPres, then the following sub:
Sub PasteRng(Pres, SlideNo, Rng As Range)
Rng.Copy ' copy the range
Pres.Application.ActiveWindow.View.GotoSlide SlideNo 'PPSlide.SlideIndex ' activate the slide no
Pres.Application.ActiveWindow.View.PasteSpecial ppPasteOLEObject, msoFalse ' paste using pastespecial method
End Sub
can be called as part of your main sub multiple times:
PasteRng PPPres, 5, Range("Rang1")
PasteRng PPPres, 8, Range("Rang2")
PasteRng PPPres, 10, Range("Rang3")
PasteRng PPPres, 14, Range("Rang4")
PasteRng PPPres, 17, Range("Rang5")
PasteRng PPPres, 23, Range("Rang6")

I'm not au fait with PowerPoint vba code so there might be some hiccups (I tested this on a presentation with slides added of the type ppLayoutTitleOnly as your code does).

p45cal
08-05-2013, 02:15 PM
Afterthought; I'd better include the full code of the sub I tested with:
Sub export_to_ppt2() 'In tools Refrence add microsoft outlook
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim SlideCount As Integer
Dim shptbl As Table

Set PPApp = New PowerPoint.Application
PPApp.Visible = True
'create new ppt:
Set PPPres = PPApp.Presentations.Add
'add some slides:
For ii = 1 To 23
PPPres.Slides.Add PPPres.Slides.Count + 1, ppLayoutTitleOnly
Next ii

PasteRng PPPres, 5, Range("Rang1")
PasteRng PPPres, 8, Range("Rang2")
PasteRng PPPres, 10, Range("Rang3")
PasteRng PPPres, 14, Range("Rang4")
PasteRng PPPres, 17, Range("Rang5")
PasteRng PPPres, 23, Range("Rang6")

Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub

loveguy1977
08-05-2013, 02:21 PM
Thank you man, I really appreciate your help but I really got mad to combine your codes and I couldn't. Can you please just give me full code for one range only. I mean range1 to slide5 of opened powerpoint file that content 25 slides

p45cal
08-05-2013, 02:24 PM
Thank you man, I really appreciate your help but I really got mad to combine your codes and I couldn't. Can you please just give me full code for one range only. I mean range1 to slide5 of opened powerpoint file that content 25 slidesJust remove:
PasteRng PPPres, 8, Range("Rang2")
PasteRng PPPres, 10, Range("Rang3")
PasteRng PPPres, 14, Range("Rang4")
PasteRng PPPres, 17, Range("Rang5")
PasteRng PPPres, 23, Range("Rang6")
leaving:
PasteRng PPPres, 5, Range("Rang1")
from the code in msg#8, but don't forget to have the PasteRng sub somewhere too:
Sub PasteRng(Pres, SlideNo, Rng As Range)
Rng.Copy ' copy the range
Pres.Application.ActiveWindow.View.GotoSlide SlideNo 'PPSlide.SlideIndex ' activate the slide no
Pres.Application.ActiveWindow.View.PasteSpecial ppPasteOLEObject, msoFalse ' paste using pastespecial method
End Sub

loveguy1977
08-05-2013, 02:30 PM
I did with 3 range only and it is great (The code below) but it open new powerpoint slide. It does not paste it into opened powerpoint file




Sub export_to_ppt2() 'In tools Refrence add microsoft outlook
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim SlideCount As Integer
Dim shptbl As Table
Set PPApp = New PowerPoint.Application
PPApp.Visible = True
'create new ppt:
Set PPPres = PPApp.Presentations.Add
'add some slides:
For ii = 1 To 10
PPPres.Slides.Add PPPres.Slides.Count + 1, ppLayoutTitleOnly
Next ii
PasteRng PPPres, 5, Range("Rang1")
PasteRng PPPres, 8, Range("Rang2")
PasteRng PPPres, 10, Range("Rang3")
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub

Sub PasteRng(Pres, SlideNo, Rng As Range)
Rng.Copy ' copy the range
Pres.Application.ActiveWindow.View.GotoSlide SlideNo 'PPSlide.SlideIndex ' activate the slide no
Pres.Application.ActiveWindow.View.PasteSpecial ppPasteOLEObject, msoFalse ' paste using pastespecial method
End Sub

loveguy1977
08-05-2013, 03:16 PM
Is it possible please?

loveguy1977
08-06-2013, 06:20 AM
Any help please please

p45cal
08-06-2013, 11:30 AM
The code below will look for the active presentation of an existing instance of PowerPoint. If there isn't an existing Powerpoint presentation it will open E:\Test\aaa.pptx. It will then try and copy the ranges to the appropriate slide numbers - if there aren't enough slides the code will fall over.
Sub export_to_ppt3()
' Uses Early Binding to the PowerPoint Object Model
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide

' Reference existing instance of PowerPoint
On Error Resume Next
Set PPApp = GetObject(, "Powerpoint.Application")
On Error GoTo 0
If PPApp Is Nothing Then
Set PPApp = New PowerPoint.Application
PPApp.Visible = True
Set PPPres = PPApp.Presentations.Open("E:\Test\aaa.pptx")
Else
Set PPPres = PPApp.ActivePresentation
End If
PPApp.ActiveWindow.ViewType = ppViewSlide

PasteRng PPPres, 5, Range("Rang1")
PasteRng PPPres, 8, Range("Rang2")
PasteRng PPPres, 10, Range("Rang3")
PasteRng PPPres, 14, Range("Rang4")
PasteRng PPPres, 17, Range("Rang5")
PasteRng PPPres, 23, Range("Rang6")

' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
not forgetting to have the sub PasteRng code somewhere.

loveguy1977
08-06-2013, 01:41 PM
Thank you very much
IT IS GREAT

I really appreciate your help