Copy Table from excel to powerpoint VBA

K

kumaarmg

New Member
Joined
Mar 22, 2010
Messages
5
Hi All...

Being a newbie in excel macros, I tried to google the as part of research. The request is for copying a table/chart from excel 2007 to powerpoint using VBA macro. I am able to copy the table using the range select and paste character wise, but these two are not giving me the exact output as expected (I need the exact formatting of of table in excel 2007). Have also tried the pastespecial (HTML, Pic) which are allowing only to paste them with linking to the excel sheet. Guys can you please help me in solving this issue.

Thanks
Kumar
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Sort by date Sort by votes
Thank you Jon. Here is a copy of code that I try to work, just testing on them, When I paste the second range of excel table it pops and error and the range is not copying to alignment. Where am I getting wrong...?

Error Message:
Run-time error '-2147188160(80043240)'

ShapeRange(unknown member): invalid request. To select a shape, its view must be active

ExcelVBA

Code: 
Sub CreatePPT()
Dim PPApp As PowerPoint.Application
Dim PPSlide As PowerPoint.Slide
Dim SheetName As String
Dim RangePasteType As String
Dim RangeName1, RangeName2 As String
SheetName = ActiveSheet.Name ' Both the tables are in same worksheet
RangeName1 = "C4:K12"
RangeName2 = "C17:J25"
 
If PPApp Is Nothing Then Set PPApp = New PowerPoint.Application
If PPApp.Presentations.Count = 0 Then PPApp.Presentations.Add
PPApp.Visible = True
 
'Set first slide
Set PPSlide = PPApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
 
Worksheets(SheetName).Range(RangeName1).Copy
PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
PPApp.ActiveWindow.Selection.ShapeRange.Item(1).ScaleHeight 2, msoCTrue, msoScaleFromMiddle
 
Set PPSlide = PPApp.ActivePresentation.Slides.Add(PPApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank)
Worksheets(SheetName).Range(RangeName2).Copy
PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
PPApp.ActiveWindow.Selection.ShapeRange.Item(1).ScaleHeight 2, msoCTrue, msoScaleFromMiddle
 
With PPApp.Presentations.Add
.SaveAs ("C:\Test.ppt")
.Close
End With
 
AppActivate ("Microsoft Powerpoint")
'Clean up
Set PPSlide = Nothing
Set PPApp = Nothing
End Sub

Thanks
Kumar
 
Last edited by a moderator:
Upvote 0
Hi Kumar

What line does it break on. I confess that I never tried; although I find it strange that the picture needs to be selected to change it's size / position.

That error suggests to me that it expects that the focus should be set back onto the excel range, since it works for the 1st range and not the second. So perhaps;
Code: 
Worksheets(SheetName).Activate
...before attempting the 2nd range copy.
 
Upvote 0
I just gave it a test, and as suspected there is no need to select the shape.

Compare the 1st copy and paste, versus the 2nd illustrated in red. This works for me, and I would also use the same method for 1st range copy & paste:

Code: 
Sub CreatePPT()
    Dim PPApp As PowerPoint.Application
    Dim PPSlide As PowerPoint.Slide
    Dim SheetName As String
    Dim RangePasteType As String
    Dim RangeName1, RangeName2 As String
    SheetName = ActiveSheet.Name ' Both the tables are in same worksheet
    RangeName1 = "C4:K12"
    RangeName2 = "C17:J25"
 
    If PPApp Is Nothing Then Set PPApp = New PowerPoint.Application
    If PPApp.Presentations.Count = 0 Then PPApp.Presentations.Add
    PPApp.Visible = True
 
    'Set first slide
    Set PPSlide = PPApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
 
    Worksheets(SheetName).Range(RangeName1).Copy
    PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
    PPApp.ActiveWindow.Selection.ShapeRange.Item(1).ScaleHeight 2, msoCTrue, msoScaleFromMiddle
 
    Set PPSlide = PPApp.ActivePresentation.Slides.Add(PPApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank)
    Worksheets(SheetName).Range(RangeName2).Copy
[COLOR=red]   With PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)[/COLOR]
[COLOR=red]       .Align msoAlignCenters, True[/COLOR]
[COLOR=red]       .Align msoAlignMiddles, True[/COLOR]
[COLOR=red]       .Item(1).ScaleHeight 2, msoCTrue, msoScaleFromMiddle[/COLOR]
[COLOR=red]   End With[/COLOR]
 
    With PPApp.Presentations.Add
        .SaveAs ("C:\Test.ppt")
        .Close
    End With
 
    AppActivate ("Microsoft Powerpoint")
    'Clean up
    Set PPSlide = Nothing
    Set PPApp = Nothing
End Sub
 
Upvote 0
This works for me, with no error produced and the alignment correct too:

Code: 
[COLOR=blue]Sub[/COLOR] CreatePPT()
    [COLOR=blue]Dim[/COLOR] PPApp [COLOR=blue]As[/COLOR] PowerPoint.Application
    [COLOR=blue]Dim[/COLOR] PPSlide [COLOR=blue]As[/COLOR] PowerPoint.Slide
    [COLOR=blue]Dim[/COLOR] SheetName [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR]
    [COLOR=blue]Dim[/COLOR] RangePasteType [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR]
    [COLOR=blue]Dim[/COLOR] RangeName1, RangeName2 [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR]
    SheetName = ActiveSheet.Name [COLOR=green]' Both the tables are in same worksheet[/COLOR]
    RangeName1 = "C4:K12"
    RangeName2 = "C17:J25"
 
    [COLOR=blue]If[/COLOR] PPApp [COLOR=blue]Is[/COLOR] [COLOR=blue]Nothing[/COLOR] [COLOR=blue]Then[/COLOR] [COLOR=blue]Set[/COLOR] PPApp = [COLOR=blue]New[/COLOR] PowerPoint.Application
    [COLOR=blue]If[/COLOR] PPApp.Presentations.Count = 0 [COLOR=blue]Then[/COLOR] PPApp.Presentations.Add
    PPApp.Visible = [COLOR=blue]True[/COLOR]
 
    [COLOR=green]'Set first slide[/COLOR]
    [COLOR=blue]Set[/COLOR] PPSlide = PPApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
 
    Worksheets(SheetName).Range(RangeName1).Copy
    [COLOR=blue]With[/COLOR] PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)
        .Align msoAlignCenters, [COLOR=blue]True[/COLOR]
        .Align msoAlignMiddles, [COLOR=blue]True[/COLOR]
        .Item(1).ScaleHeight 2, msoCTrue, msoScaleFromMiddle
    [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
 
    [COLOR=blue]Set[/COLOR] PPSlide = PPApp.ActivePresentation.Slides.Add(PPApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank)
    Worksheets(SheetName).Range(RangeName2).Copy
    [COLOR=blue]With[/COLOR] PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)
        .Align msoAlignCenters, [COLOR=blue]True[/COLOR]
        .Align msoAlignMiddles, [COLOR=blue]True[/COLOR]
        .Item(1).ScaleHeight 2, msoCTrue, msoScaleFromMiddle
    [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
 
    [COLOR=blue]With[/COLOR] PPApp.Presentations.Add
        .SaveAs ("C:\Test.ppt")
        .Close
    [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
 
    [COLOR=blue]AppActivate[/COLOR] ("Microsoft Powerpoint")
    [COLOR=green]'Clean up[/COLOR]
    [COLOR=blue]Set[/COLOR] PPSlide = [COLOR=blue]Nothing[/COLOR]
    [COLOR=blue]Set[/COLOR] PPApp = [COLOR=blue]Nothing[/COLOR]
[COLOR=blue]End[/COLOR] [COLOR=blue]Sub[/COLOR]

Please let me know what error you encounter, and on which line, if it doesn't work for you. FWIW I'm using XL03.
 
Last edited:
Upvote 0
Cool. Its working now, I am using Office 2007. This script is part of migration from 2003 VBA macro to 07. Doing this as some of the functionality were removed by in 07. Thanks much Jon.
 
Upvote 0
Hi everybody,
sorry to bump this thread but I adapted Jon's code to my needs and it works like a charm; thanks for this.

I am now trying to integrate some more features to it but being a novice in VBA I found it really difficult and so far I could not work out a solution on my own.

I added a custom layout but no matter how hard I try I can't set a title to the slide.
I changed the Layout to ppLayoutTitleOnly but how exactly am I supposed to fill in the text?

Code: 
Sub CreatePPT()    Dim PPApp As PowerPoint.Application
    Dim PPSlide As PowerPoint.Slide
    Dim SheetName1, SheetName2 As String
    Dim RangePasteType As String
    Dim RangeName As String
   
    RangeName = "A7:H12"
    SheetName1 = "AU"
    SheetName2 = "CN"
 
    If PPApp Is Nothing Then Set PPApp = New PowerPoint.Application
    If PPApp.Presentations.Count = 0 Then PPApp.Presentations.Add
    PPApp.Visible = True
    
[COLOR=#008000]    'Set Template[/COLOR]
[COLOR=#008000]    PPApp.ActivePresentation.ApplyTemplate "D:\Path\Filename.potx"[/COLOR]


    'Set first slide
    Set PPSlide = PPApp.ActivePresentation.Slides.Add(1, [COLOR=#008000]ppLayoutTitleOnly[/COLOR])
    Worksheets(SheetName1).Range(RangeName).Copy
    PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
    PPApp.ActiveWindow.Selection.ShapeRange.Item(1).ScaleWidth 0.85, msoCTrue, msoScaleFromMiddle
   
    'Set new slide 
    Set PPSlide = PPApp.ActivePresentation.Slides.Add(PPApp.ActivePresentation.Slides.Count + 1, [COLOR=#008000]ppLayoutTitleOnly[/COLOR])
    Worksheets(SheetName2).Range(RangeName).Copy
    With PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)
       .Align msoAlignCenters, True
       .Align msoAlignMiddles, True
       .Item(1).ScaleHeight 0.85, msoCTrue, msoScaleFromMiddle
    End With
          
    'Save and close
    With PPApp.Presentations.Add
        .SaveAs ("C:\Test.ppt")
        .Close
    End With
 
    AppActivate ("Microsoft Powerpoint")
   
   'Clean up
    Set PPSlide = Nothing
    Set PPApp = Nothing
End Sub

I am using Office 2010 on Windows XP.

Thanks in advance, your forum is a great help in learning new things.
 
Last edited:
Upvote 0
with me that's 4057 views - I don't believe it when you look at viewing figures for other threads....
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question
Copy Excel row and paste in Powerpoint
Replies
7
Views
176
XLfriend777
XLfriend777
J
  • Question
VBA Copy from Excel, Paste to Powerpoint
Replies
1
Views
515
SeniorNewbie
SeniorNewbie
F
  • Question
Excel VBA to Powerpoint - paste special chart object link
Replies
3
Views
957
Domenic
D
B
  • Question
Excel to PowerPoint - Was working, not generating error....
Replies
1
Views
684
BuJay
B
P
  • Question
Copy and pasting question when moving ranges from a workbook into powerpoint
Replies
0
Views
212
PaulWilson
P

Forum statistics

Threads
1,214,833
Messages
6,121,857
Members
449,051
Latest member
excelquestion515

Share this page

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