I've the following piece of code which exports excel sheets to powerpoint. In each sheet it takes the range from cells A1 and A2 and copies that range into powerpoint.
Now I want to add two functions, but I have no clue how to do this, so I am hoping anyone can help me with this?
1 - In sheets where only a table is included, the code does exactly what it's supposed to do. However in some sheets I've included a picture or a chart and these are not properly pasted in excel. (only a blank picture is copied in the powerpoint slide). Now I want to make a code that uses my input from cell "C1" to determine whether this slide needs to be pasted as an image or as a normal paste. I've tried to fix this but my code continuously gets an error. Is there any way that I can adjust this code so that I will get it working?
2 - The code now copies all worksheets, but I want it to start at sheet 7 and continue from there till the end. Thus skipping the first 6 worksheets. Does anyone have a clue how I can exclude these sheets in my VBA?
Sub PrintPPT()
'Step 1: Declare variables
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim xlwksht As Worksheet
Dim MyRange As String
'Step 2: Open PowerPoint, add a new presentation and make visible
Set pp = CreateObject("PowerPoint.Application")
Set PPPres = pp.Presentations.Add
pp.Visible = True
'Step 3: Start the loop through each worksheet
For Each xlwksht In ActiveWorkbook.Worksheets
MyRange = xlwksht.Range("A1").Value & ":" & xlwksht.Range("A2").Value
xlwksht.Range(MyRange).Copy
'Step 4: Count slides and add new blank slide as next available slide number
'(the number 12 represents the enumeration for a Blank Slide)
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)
PPSlide.Select
'Step 5: Paste the picture and adjust its position
PPPres.ApplyTemplate ("C:\Users\Template.potx")
Pastetype = xlwksht.Range("C1").Value
' Pastetype will be "PasteSpecial DataType:=2" for images
' Pastetype will be "Paste.Select" for normal
PPSlide.Shapes.pastetype '2 = ppPasteEnhancedMetafile
'pp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pp.ActiveWindow.Selection.ShapeRange.Top = 85
pp.ActiveWindow.Selection.ShapeRange.Left = 7.2
'pp.ActiveWindow.Selection.ShapeRange.Width = 600
'Step 6: Add the title to the slide then move to next worksheet
Next xlwksht
'Step 7: Memory Cleanup
pp.Activate
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing
End Sub
Related
I am new to VBA and presently copy pasting data from Excel to power point slides manually. Each PowerPoint slide has charts, text boxes and tables. So I want to copy data in the excel sheet and paste to PowerPoint without losing the original formatting and ability to change data in text boxes and tables. I found below macro which copy paste Excel sheet as a picture. But my problem is how can I paste the copied data in original format (i.e. Table, text box, chart, etc…). Any help is really appreciated.
Sub WorkbooktoPowerPoint()
'Step 1: Declare your variables
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim xlwksht As Worksheet
Dim MyRange As String
Dim MyTitle As String
'Step 2: Open PowerPoint, add a new presentation and make visible
Set pp = CreateObject("PowerPoint.Application")
Set PPPres = pp.Presentations.Add
pp.Visible = True
'Step 3: Set the ranges for your data and title
MyRange = "A1:H40" '<<<Change this range
'Step 4: Start the loop through each worksheet
For Each xlwksht In ActiveWorkbook.Worksheets
xlwksht.Select
Application.Wait (Now + TimeValue("0:00:1"))
'Step 5: Copy the range as picture
xlwksht.Range(MyRange).CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
'Step 6: Count slides and add new blank slide as next available slide number
'(the number 16 represents the enumeration for a Blank Slide)
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 16)
PPSlide.Select
'Step 7: Paste the picture and adjust its position
PPSlide.Shapes.Paste.Select
pp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pp.ActiveWindow.Selection.ShapeRange.Top = 1
pp.ActiveWindow.Selection.ShapeRange.Left = 1
pp.ActiveWindow.Selection.ShapeRange.Width = 500
'Step 8: Add the title to the slide then move to next worksheet
Next xlwksht
'Step 9: Memory Cleanup
pp.Activate
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing
End Sub
Try to use the copychart method intead of copypicture. It will retain the format and datasoyrce of the chart
First, thank you very much for making your code very easy to read and follow that makes this process so much easier!
For the most part, your code is spot on, we just have to change one section of it. The part we need to change is the paste section. We are going to change it to the PasteSpecial method because with this method we get a few more options on how we can paste it into PowerPoint.
Here is how the code will look after we change it from the Paste method to the PasteSpecial method:
'Paste the picture and adjust its position
PPSlide.Shapes.PasteSpecial DataType:=3 'This is ppPasteMetafilePicture
Keep in mind I passed through a new parameter which specifies the paste data type. I chose the ppPasteMetaFilePicture because you asked to keep the formatting. However, because we are using late binding in this code we have to use the enumeration which in this case is 3.
Now, unfortunately, pasting objects in PowerPoint or any office application can be very volatile sometimes, so there might be extra steps you need to take in order to make sure the code behaves as you expected. There are also several different ways you can paste a picture in PowerPoint and each has their own unique features.
I actually made a YouTube video where we go over how to paste objects from Excel to PowerPoint because it is such a common request. If you'd like to see the video you can just follow the link below.
https://youtu.be/cpwHL26Nxhc
Full disclosure this is my personal YouTube account.
I have an excel workbook with 20 sheets and I am trying to import these excel sheets into powerpoint using a VBA. I've been able to compose a piece of code which does almost exactly what I need to do, however I am unable to find the solution for the last part.. Hope you guys can help me out!
From each sheet I need to select a different range (which is visible in cell A1 and A2 of each sheet).
for example from excel sheet 1 I have in cell A1 "B3" and in cell A2 "D12", which means that for this sheet the VBA should copy range B3:D12.
In the next sheet exactly the same should happen, however it should adjust its range based on what I've given up in cell A1 and A2 of that sheet.
My code so far is as follows:
Sub PrintPPT()
'Step 1: Declare variables
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim xlwksht As Worksheet
Dim MyRange As String
Dim Cval1 As Variant
Dim Cval2 As Variant
Dim Rng1 As Range
'Step 2: Open PowerPoint, add a new presentation and make visible
Set pp = CreateObject("PowerPoint.Application")
Set PPPres = pp.Presentations.Add
pp.Visible = True
'Step 3: Set the ranges for the data
Cval1 = ActiveSheet.Range("A1").Value
Cval2 = ActiveSheet.Range("A2").Value
Set Rng1 = ActiveSheet.Range("Cval1 : Cval2")
MyRange = "Rng1"
'Step 4: Start the loop through each worksheet
For Each xlwksht In ActiveWorkbook.Worksheets
xlwksht.Select
Application.Wait (Now + TimeValue("0:00:1"))
'Step 5: Copy the range as picture
xlwksht.Range(MyRange).Copy
'Step 6: Count slides and add new blank slide as next available slide number
'(the number 12 represents the enumeration for a Blank Slide)
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)
PPSlide.Select
'Step 7: Paste the picture and adjust its position
PPPres.ApplyTemplate ("C:\Users\Computer\Documents\Templates\Template.potx")
PPSlide.Shapes.Paste.Select
pp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pp.ActiveWindow.Selection.ShapeRange.Top = 80
pp.ActiveWindow.Selection.ShapeRange.Left = 7.2
pp.ActiveWindow.Selection.ShapeRange.Width = 600
'Step 8: Add the title to the slide then move to next worksheet
Next xlwksht
'Step 9: Memory Cleanup
pp.Activate
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing
End Sub
IF you want the values in cell A1 And A2, you can't put the variables in quotes when building your range.
Set Rng1 = ActiveSheet.Range("Cval1 : Cval2")
Will give you a Rng1 as Cval1 : Cval2
Set Rng1 = ActiveSheet.Range(Cval1 & ":" & Cval2)
Will give you (from your example) Rng1 = B3:D12
This should be all you need. I haven't tested it, so there may be some tweeking needed.
Sub PrintPPT()
'Step 1: Declare variables
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim xlwksht As Worksheet
Dim MyRange As String
'Step 2: Open PowerPoint, add a new presentation and make visible
Set pp = CreateObject("PowerPoint.Application")
Set PPPres = pp.Presentations.Add
pp.Visible = True
'Step 3: Start the loop through each worksheet
For Each xlwksht In ActiveWorkbook.Worksheets
MyRange = xlwksht.Range("A1").Value & ":" & xlwksht.Range("A2").Value
xlwksht.Range(MyRange).Copy
'Step 4: Count slides and add new blank slide as next available slide number
'(the number 12 represents the enumeration for a Blank Slide)
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)
PPSlide.Select
'Step 5: Paste the picture and adjust its position
PPPres.ApplyTemplate ("C:\Users\Computer\Documents\Templates\Template.potx")
PPSlide.Shapes.Paste.Select
pp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pp.ActiveWindow.Selection.ShapeRange.Top = 80
pp.ActiveWindow.Selection.ShapeRange.Left = 7.2
pp.ActiveWindow.Selection.ShapeRange.Width = 600
'Step 6: Add the title to the slide then move to next worksheet
Next xlwksht
'Step 7: Memory Cleanup
pp.Activate
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing
End Sub
I have a master PowerPoint presentation that has ~60 slides.
I want to go through the entire deck and copy specific slides that have certain text. I can create an array with the key words that form the basis of the selection but cannot figure out how to copy the entire slide.
Below code is the result of foraging on the internet.
Sub selct()
Dim pres1 As PowerPoint.Presentation, pres2 As PowerPoint.Presentation,
pp As Object
Set pp = GetObject(, "PowerPoint.Application")
Set pres1 = pp.ActivePresentation
Set pres2 = pp.Presentations.Add
Dim i As Long, n As Long
Dim TargetList
'~~> Array of terms to search for
TargetList = Array("Agenda", "Review", "third", "etc")
'~~> Loop through each slide
For Each sld In pres1.Slides
'~~> Loop through each shape
For Each shp In sld.Shapes
'~~> Check if it has text
If shp.HasTextFrame Then
Set txtRng = shp.TextFrame.TextRange
For i = 0 To UBound(TargetList)
'~~> Find the text
Set rngFound = txtRng.Find(TargetList(i))
'~~~> If found
Do While Not rngFound Is Nothing
'~~> Set the marker so that the next find starts from here
n = rngFound.Start + 1
'~~> Chnage attributes
With rngFound.Font
.Bold = msoFalse
sld.Copy
pres2.Slides.Paste
'~~> Find Next instance
Set rngFound = txtRng.Find(TargetList(i), n)
End With
Loop
Next
End If
Next
Next
End Sub
The above copies the slides but not the formatting. Additionally, the slides get repeated such that the number of slides in the new presentation number that in the master presentation, when it should be a subset. For example, the master has 60 slides, and the new presentation also has 60 slides instead of 20, say.
How do I copy just the slides that have the specific words as in the target array and keep the formatting of the slides as well?
I think first you need to ensure that pres2 is using the same design template/theme as pres1. If pres2 is using a different theme, then the slides will reflect that theme. I don't recall how to do that without spending some time debugging it, but since you're starting from a blank presentation, probably this is easiest:
First, delete all slides from pres2:
Set pres2 = pp.Presentations.Add
Dim i as Long
For i = pres2.Slides.Count to 1 Step - 1
pres2.Slides(i).Delete
Next
Now you have an empty presentation, and Paste the slides from pres1 should preserve the layout/theme.
sld.Copy
pres2.Slides.Paste
I have the code that is used to copy the image from one worksheet and paste it on a new workbook.
My problem is that ' it works only if the image is attached within the range .i want the code that works even if the image is attached over the worksheet'.
Note : input file may contain's multiple image
My code is :
Set xlwbkinput = ActiveWorkbook
Set xlwbkoutput = Excel.Workbooks.Add
shtcountip = xlwbkinput.Sheets.Count
shtcountop = xlwbkoutput.Sheets.Count
If shtcountop < shtcountip Then
For i = shtcountop To shtcountip + 1
xlwbkoutput.Worksheets.Add After:=xlwbkoutput.Worksheets(xlwbkoutput.Worksheets.Count)
Next i
End If
For i = 1 To shtcountip 'it runs till the input workbook have the last sheet
xlwbkinput.Worksheets(i).Activate
xlwbkinput.Worksheets(i).Range("A1:AZ200").Copy 'here I'm copying input sheet
xlwbkoutput.Worksheets(i).Activate
xlwbkoutput.Worksheets(i).Paste 'here I'm pasting in my new worksheet
Next i
Thanks in Advance!!!!
The For loop below will iterate through all shapes in xlwbkinput.Worksheets(1) (which is the worksheet with index 1).
Then it checks if the current Shape (picture) cell position is larger then 1, which means it checks if the current picture's is positioned in any cell which starts from the 2nd row - you can easily modify that criteria.
Dim myPics As Shape
' loop through all shapes in Worksheets(1)
For Each myPics In xlwbkinput.Worksheets(1).Shapes
If myPics.TopLeftCell.Row > 1 Then ' check if current shape's row is larger than 1
myPics.Copy '<-- copy the current picture
End If
Next myPics
Give the following approach a try:
Option Explicit
Public Sub tmpSO()
Dim picIn As Picture
Dim picOut As Picture
Dim wksInput As Worksheet
Dim wksOutput As Worksheet
Dim cht As ChartObject
Set wksInput = ThisWorkbook.Worksheets("Sheet1")
Set wksOutput = ThisWorkbook.Worksheets("Sheet2")
For Each picIn In wksInput.Pictures
Set cht = wksInput.ChartObjects.Add(0, 0, picIn.Width, picIn.Height)
cht.Chart.Parent.Border.LineStyle = 0
picIn.Copy
cht.Chart.ChartArea.Select
cht.Chart.Paste
cht.Chart.Export Filename:=Environ("Temp") & "\someTempPicName.jpg", filtername:="JPG"
Set picOut = wksOutput.Pictures.Insert(Environ("Temp") & "\tmpPic5022.jpg")
picOut.Left = picIn.Left
picOut.Top = picIn.Top
cht.Delete
Kill Environ("Temp") & "\someTempPicName.jpg"
Next picIn
End Sub
This solution uses the worksheet.Pictures collection to iterate through all pictures on a sheet. The easiest way would be to simply .Copy and .Paste these pictures from one sheet to another. Yet, this approach would neglect the location of each picture on the sheet. Assuming that you want you pictures not randomly located on you output sheet, the above code will also copy the location from the input sheet.
I am trying to prepare code to copy and paste excel data range from excel sheet to powerpoint slide but I am able to paste images only.
Please help with the suitable code. The code I am using is as follows:
Sub WorkbooktoPowerPoint()
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim Rng As Range
Set pp = CreateObject("PowerPoint.Application")
Set PPPres = pp.Presentations.Add
pp.Visible = True
Set Rng = ActiveSheet.Range("B1:J31")
Rng.Copy
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)
PPSlide.Shapes.PasteSpecial ppPasteOLEObject
PPSlide.Shapes(1).Select
pp.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, True
pp.ActiveWindow.Selection.ShapeRange.Top = 65
pp.ActiveWindow.Selection.ShapeRange.Left = 7.2
pp.ActiveWindow.Selection.ShapeRange.Width = 700
pp.Activate
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing
End Sub
It still surprises me that many of the PasteSpecial options are not available form the clipboard or in PowerPoint generally. I think there is a way around this using a different method. Instead of:
PPSlide.Shapes.PasteSpecial ppPasteOLEObject
Try using this method:
PPSlide.Parent.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"
I am not certain of the correct idMso argument to use but I would start with that, it looks like it works the way I would expect it to:
PowerPoint Result
Excel Table Example
If not, there are several others that might be worth checking:
PasteSourceFormatting
PasteDestinationTheme
PasteAsEmbedded
PasteExcelTableSourceFormatting
PasteExcelTableDestinationTableStyle
This method is not as well-documented compared to many other methods. The Application.CommandBars property reference has nary a mention of the ExecuteMso method, which I found some information about here (and on SO where I have seen it used once or twice before):
The full list of idMso parameters to explore, which come as part of a rather large executable for use with fluent ribbon UI design, current for Office 2013 I believe:
http://www.microsoft.com/en-us/download/details.aspx?id=727
Another method for getting the data from Excel to PPT slides without VBA code also possible.
Note: save both workbook and PPT file in one location.
Step 1: Copy excel data / table
Step 2: Go to Power point slides
Step 3: Select Paste special option
Step 4: Select "Paste Link" radio button
Step 5: Click on Ok
Then save the files then change the data in excel, now it will automatically copy the data based linking the connection.
Hope this option helps.
Thanks,
Gourish
To take an Excel range and paste it into a PowerPoint Application, requires breaking down the process into a few different parts. Looking at your code, we can break it down to the following components:
Create an instance of PowerPoint.
Create your slide & presentation.
Create a reference to the range you want to export & then copy it.
Align the shape to the desired dimensions.
Finally, release your objects from memory.
I am assuming that you want this code left as late-binding, but there are also sections of your code that will cause issues because you are treating it like it was written in early-binding.
Also, I have a YouTube video on this topic, so feel free to watch the series if you want to do a more complicated paste or if you're working with multiple Excel Ranges.
Link to Playlist:
https://www.youtube.com/playlist?list=PLcFcktZ0wnNlFcSydYb8bI1AclQ4I38VN
SECTION ONE: DECLARE THE VARIABLES
Here we will just create all the variables we need in our script.
'Declare PowerPoint Variables
Dim PPTApp As Object
Dim PPTPres As Object
Dim PPTSlide As Object
'Dim Excel Variables
Dim ExcRng As Range
SECTION TWO: CREATE A NEW INSTANCE OF POWERPOINT
This will create a new PowerPoint application, make it visible and make it the active window.
'Create a new PowerPoint Application and make it visible.
Set PPTApp = CreateObject("PowerPoint.Application")
PPTApp.Visible = True
PPTApp.Activate
SECTION THREE: CREATE A NEW PRESENTATION & SLIDE
This will add a new presentation to the PowerPoint Application, create a new slide in the presentation and set the layout as a blank layout.
'Create a new Presentation
Set PPTPres = PPTApp.Presentations.Add
'Create a new Slide
Set PPTSlide = PPTPres.Slides.Add(1, 12) '<<< THIS 12 MEANS A BLANK LAYOUT.
SECTION FOUR: CREATE A REFERENCE TO THE EXCEL RANGE & COPY IT
This will set a reference to our Excel range we want to copy and copy it.
'Set a reference to the range
Set ExcRng = Range("B1:J31")
'Copy Range
ExcRng.Copy
SECTION FOUR: PASTE IN SLIDE AS OLEOBJECT
This will paste the range in the slide and set a reference to it.
'Paste the range in the slide
SET PPTShape = PPTSlide.Shapes.PasteSpecial(10) '<<< 10 means OLEOBJECT
SECTION FIVE: ALIGN THE SHAPE
This will select the shape and set the dimensions of it.
'Select the shape.
PPTSlide.Shapes(PPTSlide.Shapes.Count).Select
'Set the Dimensions of the shape.
With PPTApp.ActiveWindow.Selection.ShapeRange
.Top = 65
.Left = 7.2
.Width = 700
End With
SECTION SIX: RELEASE OBJECTS FROM MEMORY
This will release the objects from memory.
'Erase Objects from memory.
Set PPTApp = Nothing
Set PPTSlide = Nothing
Set PPTShape = Nothing
In full, this is how your code will now look:
Sub ExportRangeToPowerPoint_Late()
Dim PPTApp As Object
Dim PPTPres As Object
Dim PPTSlide As Object
Dim PPTShape As Object
Dim ExcRng As Range
'Create a new instance of PowerPoint
Set PPTApp = CreateObject("PowerPoint.Application")
PPTApp.Visible = True
PPTApp.Activate
'Create a new Presentation
Set PPTPres = PPTApp.Presentations.Add
'Create a new Slide
Set PPTSlide = PPTPres.Slides.Add(1, ppLayoutBlank)
'Set a reference to the range
Set ExcRng = Range("B1:J31")
'Copy Range
ExcRng.Copy
'Paste the range in the slide
Set PPTShape = PPTSlide.Shapes.PasteSpecial(10)
'Select the shape.
PPTSlide.Shapes(PPTSlide.Shapes.Count).Select
'Set the Dimensions of the shape.
With PPTApp.ActiveWindow.Selection.ShapeRange
.Top = 65
.Left = 7.2
.Width = 700
End With
'Erase Objects from memory.
Set PPTApp = Nothing
Set PPTSlide = Nothing
Set PPTShape = Nothing
End Sub