Solved

Multiple excel tab ranges to powerpoint slides

Posted on 2013-12-06
14
1,268 Views
Last Modified: 2013-12-09
I have a macro that does what I want but need to streamline it so if I need to change, for example the width, I only want to change it in one spot versus multiple times.

Partial code:
PPApp.ActiveWindow.View.GotoSlide (26)
Set PPSlide = PPApp.ActiveWindow.View.Slide
        Sheets("Connects_BO").Select
        LockAspectRatio = False
        ActiveSheet.Range(stBO).Copy
         PPSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile).Select
        PPApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
        PPApp.ActiveWindow.Selection.ShapeRange.ScaleHeight 1, False
        PPApp.ActiveWindow.Selection.ShapeRange.ScaleWidth 1, False
        PPApp.ActiveWindow.Selection.ShapeRange.Width = 713
        PPApp.ActiveWindow.Selection.ShapeRange.Height = 320#
    ' Realign:
        PPApp.ActiveWindow.Selection.ShapeRange.Top = 70
        PPApp.ActiveWindow.Selection.ShapeRange.Left = 4
       
PPApp.ActiveWindow.View.GotoSlide (27)
Set PPSlide = PPApp.ActiveWindow.View.Slide
        Sheets("Hours_BO").Select
        LockAspectRatio = False
        ActiveSheet.Range(stBO).Copy
         PPSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile).Select
        PPApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
        PPApp.ActiveWindow.Selection.ShapeRange.ScaleHeight 1, False
        PPApp.ActiveWindow.Selection.ShapeRange.ScaleWidth 1, False
        PPApp.ActiveWindow.Selection.ShapeRange.Width = 713
        PPApp.ActiveWindow.Selection.ShapeRange.Height = 320#
    ' Realign:
        PPApp.ActiveWindow.Selection.ShapeRange.Top = 70
        PPApp.ActiveWindow.Selection.ShapeRange.Left = 4
       
PPApp.ActiveWindow.View.GotoSlide (28)
Set PPSlide = PPApp.ActiveWindow.View.Slide
        Sheets("Sat_BO").Select
        LockAspectRatio = False
        ActiveSheet.Range(stBO).Copy
         PPSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile).Select
        PPApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
        PPApp.ActiveWindow.Selection.ShapeRange.ScaleHeight 1, False
        PPApp.ActiveWindow.Selection.ShapeRange.ScaleWidth 1, False
        PPApp.ActiveWindow.Selection.ShapeRange.Width = 713
        PPApp.ActiveWindow.Selection.ShapeRange.Height = 320#
    ' Realign:
        PPApp.ActiveWindow.Selection.ShapeRange.Top = 70
        PPApp.ActiveWindow.Selection.ShapeRange.Left = 4
0
Comment
Question by:DCUnited
  • 6
  • 4
  • 3
  • +1
14 Comments
 
LVL 43

Expert Comment

by:Saqib Husain, Syed
ID: 39701687
Something like

Dim slWidth As Integer
Dim slHeight As Integer
Dim slTop As Integer
Dim slLeft As Integer
slWidth = 713
slHeight = 320
slTopDim = 70
slLeft = 4
PPApp.ActiveWindow.View.GotoSlide (26)
Set PPSlide = PPApp.ActiveWindow.View.Slide
        Sheets("Connects_BO").Select
        LockAspectRatio = False
        ActiveSheet.Range(stBO).Copy
         PPSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile).Select
        PPApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
        PPApp.ActiveWindow.Selection.ShapeRange.ScaleHeight 1, False
        PPApp.ActiveWindow.Selection.ShapeRange.ScaleWidth 1, False
        PPApp.ActiveWindow.Selection.ShapeRange.Width = slWidth
        PPApp.ActiveWindow.Selection.ShapeRange.Height = slHeight
    ' Realign:
        PPApp.ActiveWindow.Selection.ShapeRange.Top = slTop
        PPApp.ActiveWindow.Selection.ShapeRange.Left = slLeft
.
.
and so on
0
 
LVL 35

Expert Comment

by:mvidas
ID: 39701701
DCU,

You could also create a function that does what you want, and just pass it the things that are different. Replace your block with:
        Call XLtoPP(PPApp, PPApp.ActivePresentation.Slides(26), Sheets("Connects_BO").Range(stBO))
        Call XLtoPP(PPApp, PPApp.ActivePresentation.Slides(27), Sheets("Hours_BO").Range(stBO))
        Call XLtoPP(PPApp, PPApp.ActivePresentation.Slides(28), Sheets("Sat_BO").Range(stBO))

Open in new window

Then at the end of the module, paste in the following:
Function XLtoPP(PPApp As PowerPoint.Application, PPSlide As PowerPoint.Slide, XLRg As Range)
    LockAspectRatio = False
    XLRg.Copy
    PPSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile).Select
    PPApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
    PPApp.ActiveWindow.Selection.ShapeRange.ScaleHeight 1, False
    PPApp.ActiveWindow.Selection.ShapeRange.ScaleWidth 1, False
    PPApp.ActiveWindow.Selection.ShapeRange.Width = 713
    PPApp.ActiveWindow.Selection.ShapeRange.Height = 320#
' Realign:
    PPApp.ActiveWindow.Selection.ShapeRange.Top = 70
    PPApp.ActiveWindow.Selection.ShapeRange.Left = 4
End Function

Open in new window

Then to tweak it, or if there is more you want to add to your process, just change the function.

Matt
0
 

Author Comment

by:DCUnited
ID: 39701755
Matt this looks like what I want, but when the code got to the Function piece I got a Run-time error stating that the shape range's view must be active at the line
PPSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile).Select
0
 
LVL 23

Accepted Solution

by:
JSRWilson earned 188 total points
ID: 39701772
Doesn't this work?

It is nearly always a bad idea to select things in PPT code.

'change values here
Const sngW As Single = 713
Const sngH As Single = 320
Const sngT As Single = 70
Const sngL As Single = 4

Dim ppSlide As Object
Dim pptPaste As Object

Set ppSlide = pptApp.ActivePresentation.Slides(2)
Sheets("Connects_BO").Select
LockAspectRatio = False
ActiveSheet.Range(stBO).Copy
Set pptPaste = ppSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
With pptPaste(1)
.Width = sngW
.Height = sngH
.Left = sngL
.Top = sngT
End With
0
 
LVL 35

Expert Comment

by:mvidas
ID: 39701773
Of course, that was poor thinking on my part. Here is the same thing without selecting the area:
Function XLtoPP(PPApp As PowerPoint.Application, PPSlide As PowerPoint.Slide, XLRg As Range)
    LockAspectRatio = False
    XLRg.Copy
    With PPSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
        .ShapeRange.LockAspectRatio = msoFalse
        .ShapeRange.ScaleHeight 1, False
        .ShapeRange.ScaleWidth 1, False
        .ShapeRange.Width = 713
        .ShapeRange.Height = 320#
' Realign:
        .ShapeRange.Top = 70
        .ShapeRange.Left = 4
   End With
End Function

Open in new window

0
 
LVL 23

Expert Comment

by:JSRWilson
ID: 39701777
What are scaleHeight / width doing??
0
 

Author Comment

by:DCUnited
ID: 39701818
It didn't like that version either. However I did tweek the other version and got it to work but all it did was save that last slide over and over again on the 1st slide which is my title page and I have it set to slide (2) to start.
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 

Author Comment

by:DCUnited
ID: 39701820
the ScaleHeight/ScaleWidth was in this horrible designed report when I took it over
0
 

Author Comment

by:DCUnited
ID: 39701841
I was thinking this could be done using With
I get the method or data member not found with the .ShapeRange
0
 
LVL 23

Expert Comment

by:JSRWilson
ID: 39701880
That's because a ShapeRange doesn't really have .Left property etc Shapes do.

You would need to say .ShapeRange(1) - First shape in the range
(some versions of PPT will accept the incorrect code if only one shape is pasted but others won't and you didn't say which version)

You will see in my code I refer to pptPaste(1) not pptPaste - first shape in the pasted shapes.

Which slide(s) do you want it to paste to??
0
 

Author Comment

by:DCUnited
ID: 39701892
I am using 2007. As far as which slide, it depends on the excel tab. Each tab name will be copied to a specific slide number.
0
 
LVL 23

Expert Comment

by:JSRWilson
ID: 39702806
You need to explain a little more than that if you need code to achieve that!
0
 
LVL 35

Assisted Solution

by:mvidas
mvidas earned 187 total points
ID: 39705955
DCU,

Putting together JSRWilson's corrections with my code gives this; give it a shot with the 3 lines I originally gave you to call the function:
Function XLtoPP(PPApp As PowerPoint.Application, PPSlide As PowerPoint.Slide, XLRg As Range)
    Dim PPPaste As Object
    XLRg.Copy
    Set PPPaste = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
    With PPPaste(1).ShapeRange(1)
        .LockAspectRatio = msoFalse
        .ScaleHeight 1, False
        .ScaleWidth 1, False
        .Width = 713
        .Height = 320#
' Realign:
        .Top = 70
        .Left = 4
   End With
End Function

Open in new window

0
 

Author Closing Comment

by:DCUnited
ID: 39706851
I was hoping to do something like a call function like mvidas suggested, but couldn't get it to work. Went back to original plan of action like what JSRWilson provided.
0

Featured Post

Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

Join & Write a Comment

Background   Certain code in VBA requires initialization, such as application events. The app initialization is often triggered by the Auto_Open sub which is a special procedure that runs when an add-in loads. More significantly, this sub does n…
Preface: When I started this series, I used the term CommandBars because that is the Office Object class that it discusses. Unfortunately, when Microsoft introduced Office 2007, they replaced the standard Commandbar menus with "The Ribbon" and rem…
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.

747 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

9 Experts available now in Live!

Get 1:1 Help Now