The problem I am trying to solve is to automate the copy and paste from Excel to powerPoint which at the moment is time consuming because we deal with lots of charts in different sheets. So I did some research online to see if anyone else tried or succeeded at the task and here is the fruits of the research. However, it doesn't fully satisfy my purposes because even though it successfully copies and pastes in to powerpoint, the ordering is messed up since it paste from oldest to newest.
I tried to used create a loop that starts in the last sheet to the first but having multiple charts per sheet still messed up the ordering in which I would like to see the charts displayed.
Sub chart_deliveryReverse()
'declaring all of the objects that will be used
Dim objPP, objPPFile, mySlide, myShape As Object
Dim DestinationPPT, button As String
Dim sht As Worksheet
Dim charts As Long
Dim counter, counter1 As Integer
Dim Xchart As Excel.ChartObject
'Message Box with a message giving the user Feedback
button1 = MsgBox("Creating PowerPoint")
'assign the objPP to powerPoint App
Set objPP = CreateObject("PowerPoint.Application")
'make it visible in the screen
objPP.Visible = True
'open specific powerPoint presentation
DestinationPPT = "location of powerPoint"
Set objPPFile = objPP.Presentations.Open(DestinationPPT)
'Loop that start from beginning to ended
For counter = 1 To Worksheets.Count Step 1
'Commnented loop that starts at the last sheet to the beginning
'For counter = Worksheets.Count To 1 Step -1
Set sht = Worksheets(counter)
'Locate Excel charts to paste into the new PowerPoint presentation
For Each Xchart In sht.ChartObjects
'Copy each Excel chart and paste it into PowerPoint
sht.Activate
Xchart.Select
ActiveChart.ChartArea.Copy
'Customizes the powerPoint first number being where to start inserting slides and second number the layout
Set mySlide = objPPFile.Slides.Add(2, 11) '11 = ppLayoutTitle
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
mySlide.Shapes.PasteSpecial DataType:=6
objPP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
objPP.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
mySlide.Shapes(1).TextFrame.TextRange.Text = Xchart.Chart.ChartTitle.Text
'Align the lastest stored shape
myShape.Left = 100
myShape.Top = 50
Next
Next
'Next
' Clean up
Set objPP = Nothing
Set objPPFile = Nothing
Set mySlide = Nothing
End Sub
It opens up the specified powerpoint and populates it with the charts from the excel sheets
Related
I have an Excel with multiple sheets,each sheet having multiple charts.
I want to copy a chart from a specific sheet of an Excel, to a particular slideno in PPT; with specific dimensions (ie height and width) and positions using VBA.
I am able to do the same.
However,when im trying to do so; other shapes in the ppt are also getting re-positioned to the same position, along with the charts.
Here is my code
wkbk.Sheets("Sheet2").Shapes("chart1").Copy
ActivePresentation.Slides(1).Shapes.Range.Height = embededpicrange.Cells(1, 3).Value
ActivePresentation.Slides(1).Shapes.Range.Width = embededpicrange.Cells(1, 4).Value
How can we change the position of charts alone with the above code.
Need some guidance on this
This may be help you:
Sub copyChartToPP()
'Declare the needed variables
Dim newPP As PowerPoint.Application
Dim currentSlide As PowerPoint.Slide
Dim Xchart As Excel.ChartObject
'Check if PowerPoint is activate:
On Error Resume Next
Set newPP = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Open PowerPoint if not activate
If newPP Is Nothing Then
Set newPP = New PowerPoint.Application
End If
'Create a new presentation in powerPoint
If newPP.Presentations.Count = 0 Then
newPP.Presentations.Add
End If
'Display the PowerPoint presentation
newPowerPoint.Visible = True
'Locate Excel charts to paste into the new PowerPoint presentation
For Each Xchart In ActiveSheet.ChartObjects
'Add a new slide in PowerPoint for each Excel chart
newPP.ActivePresentation.Slides.Add newPP.ActivePresentation.Slides.Count + 1,
ppLayoutText
newPP.ActiveWindow.View.GotoSlide newPP.ActivePresentation.Slides.Count
Set currentSlide =
newPP.ActivePresentation.Slides(newPP.ActivePresentation.Slides.Count)
'Copy each Excel chart and paste it into PowerPoint as an Metafile image
Xchart.Select
ActiveChart.ChartArea.Copy
currentSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'Copy and paste chart title as the slide title in PowerPoint
currentSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
'Adjust the slide position for each chart slide in PowerPoint. Note that you can
'adjust the values to position the chart on the slide to your liking
newPP.ActiveWindow.Selection.ShapeRange.Left = 25
newPP.ActiveWindow.Selection.ShapeRange.Top = 150
currentSlide.Shapes(2).Width = 250
currentSlide.Shapes(2).Left = 500
Next
End Sub
I'm trying to automate the creation of a PowerPoint deck that I create a few times a week. I use a program called Alteryx to update the embedded excel files for all my charts in PowerPoint and that part works great. The problem that I have is that once I open PowerPoint, all the charts look the same as they originally were. It's only when I click edit data, that PowerPoint seems to read the excel changes and updates the chart. I have over 50 charts that I need to update, and clicking edit data on each one is very time consuming.
Is there a macro that can be created that will refresh all charts in my deck?
Thank you in advance for your time!
Update 1
I have tried using the following code from another post, but it results in 50 open workbooks.
Dim pptChart As Chart
Dim pptChartData As ChartData
Dim pptWorkbook As Object
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasChart Then
Set pptChart = shp.Chart
Set pptChartData = pptChart.ChartData
pptChartData.Activate
shp.Chart.REFRESH
On Error Resume Next
On Error GoTo 0
End If
Next
Next
Set pptWorkbook = Nothing
Set pptChartData = Nothing
Set pptChart = Nothing
I tried using the following code to open and close all the embedded workbooks, but it results in an error at this part "ActiveWindow.View.GotoSlide s.Slideindex"
Sub refreshchart()
Dim ppApp As PowerPoint.Application, sld As Slide
Dim s As PowerPoint.Shape
Dim gChart As Chart, i As Integer
ppApp.Visible = True
i = 3
Set sld = ActivePresentation.Slides(i)
sld.Select
For Each s In ActivePresentation.Slides(i)
If s.Type = msoEmbeddedOLEObject Then
s.Select 'select the object
s.OLEFormat.Activate 'Activate it (like 2x click))
ActiveWindow.Selection.Unselect 'To let it close
ActiveWindow.View.GotoSlide s.Slideindex 'make current slide active
End If
Next s
End Sub
A macro that opens the workbooks to refresh the charts and automatically closes them would be great. Thank you!
I am trying to copy multiple pivot graphs from excel sheet to a new ppt.
Below is the code I have tried. But, in this code after pasting the first graph it is throwing error and Power point is also crashing.
Sub ClickPpt()
'Declare the needed variables
Dim newPP As PowerPoint.Application
Dim currentSlide As PowerPoint.Slide
Dim Xchart As Excel.ChartObject
'Check if PowerPoint is active
On Error Resume Next
Err.Clear
Set newPP = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Open PowerPoint if not active
If newPP Is Nothing Then
Set newPP = New PowerPoint.Application
End If
'Create new presentation in PowerPoint
If newPP.Presentations.Count = 0 Then
newPP.Presentations.Add
End If
'Display the PowerPoint presentation
newPP.Visible = True
'Locate Excel charts to paste into the new PowerPoint presentation
For Each Xchart In ActiveSheet.ChartObjects
'Add a new slide in PowerPoint for each Excel chart
newPP.ActivePresentation.Slides.Add newPP.ActivePresentation.Slides.Count + 1, ppLayoutText
newPP.ActiveWindow.View.GotoSlide newPP.ActivePresentation.Slides.Count
Set currentSlide = newPP.ActivePresentation.Slides(newPP.ActivePresentation.Slides.Count)
'Copy each Excel chart and paste it into PowerPoint as an Metafile image
Xchart.Select
'ActiveChart.ChartArea.Copy
'currentSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
ActiveChart.Parent.Copy
currentSlide.Shapes.Paste.Select
'Copy and paste chart title as the slide title in PowerPoint
'currentSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
'Adjust the slide position for each chart slide in PowerPoint. Note that you can adjust the values to position the chart on the slide to your liking
newPP.ActiveWindow.Selection.ShapeRange.Left = 25
newPP.ActiveWindow.Selection.ShapeRange.Top = 150
currentSlide.Shapes(2).Width = 250
currentSlide.Shapes(2).Left = 500
Next
AppActivate ("Microsoft PowerPoint")
Set currentSlide = Nothing
Set newPP = Nothing
End Sub
Can someone help me with the code or provide me some code to do this process?
hope you can help.
Complete novice in VBA and I've searched and searched for an answer to my question but cannot find what I'm looking for.
What I have is a workbook with numerous tabs which hold different data and narrative. I need some way to to export these sheets (print view area) into separate PowerPoint slides only if cell "CI8" of those tabs are greater than 0. For example, I have tabs called "RestWest" "RestCentre" "RestEast" "RestRS" and if only RestWest and RestRS have their cell CI8 >0, only those two sheets would pull into Powerpoint. Pasting as a picture would be best.
I have been able to do it to export into PDF but senior management like PowerPoint better.
Hope you can help and give me some pointers.
Thanks for your time
Should have included the following code as it pulls a single sheet into PowerPoint but need to include the cell value criteria
Sub CopyRangeToPresentation()
Dim pp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim SlideTitle As String
Set pp = New PowerPoint.Application
Set PPPres = pp.Presentations.Add
pp.Visible = True
Set PPSlide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPSlide.Select
Sheets("RestWest").Range("A1:CV77").CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
PPSlide.Shapes.Paste.Select
pp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
SlideTitle = "My First PowerPoint Slide"
PPSlide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
pp.Activate
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing
End Sub
TheSpreadsheetGuru - Copy & Paste An Excel Range Into PowerPoint With VBA
I'm very novice also, but check out this link and maybe try something like:
For Each sht In Worksheets
With sht
If .Range("CI8").Value2 > 0 Then
.Range("Print_Area").Copy
'use SpreadSheetGuru to show you how to insert new slide and paste
' ...
End If
End With
Next
I am writing a macro through Excel that will help me do the steps below. Currently, I am stuck at step 3.
'Copy specific cellblock in Excel sheet
'Open existing Powerpoint presentation (which exists of four slides with approximately 6-7 charts on each slides whose underlying data has to be replaced with the copied cellblock)
'Select specific chart on slide 1
'Open the specific chart's underlying data by right clicking on "Edit Data"
Select the cellblock in the sheet that pops up and replace it with the data that was copied from Excel in step 1
My issue at the moment lies in step 3, where I am not able to select any chart in my PowerPoint. I would also appreciate all guidance that could help me with step 4 and 5 as well.
My current code looks as the following:
Sub MyMacroRätt()
'Marks and copies a cell block in my Excel file
ActiveSheet.Range("R55", "T75").Select
Selection.Copy
'Open an existing PowerPoint file
Dim PPT As PowerPoint.Application
Set PPT = New PowerPoint.Application
PPT.Visible = True
PPT.Presentations.Open Filename:="C:\Users\seleveafe\Desktop\XXXXXX.pptm"
Dim PPPres As PowerPoint.Presentation
Set PPPres = PPT.ActivePresentation
Dim pslide As PowerPoint.Slide
Dim pchart As PowerPoint.Chart
'Mark the first chart on the first slide
With ActiveWindow.Selection.ShapeRange(1)
If .HasChart = True Then
'Open Edit Data-sheet for selected chart
Chart.ActivateChartDataWindow
End If
End With
'Select existing data i Edit Data-sheet and replace with copied data from Excel
End Sub
Thanks Domenic, it actually worked!
Now I want to repeat this again for more charts in my PPT, so in the first step "Set rngCopyFrom = ActiveSheet.Range("R55", "T75") I will change the cell block that should be copied from Excel. However, when I will repeat the whole code you sent I also want to change the selected chart into THE SECOND CHART on the first slide in the PPT. Do you have ideas on how I can adjust this section so that it instead selects the second chart in slide 1, and pastes the new cell block into that charts worksheet?
If pptShape.HasChart Then 'first chart
In other words, I want a code that selects the second chart on slide 1, another code that selects the third chart on slide 1, another code that selects the fourth chart on slide 1..... and so on. In total I have 8 charts on each slide, and in total I have four slides with charts whose data that needs to be updated.
The following macro opens the specified PowerPoint file, activates the ChartData so that its workbook is opened, copies the specified data into the first worksheet of the workbook, starting at A2, and then closes it. You'll need to change the destination cell (A2) accordingly.
Option Explicit
Sub MyMacroRätt()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptShape As PowerPoint.Shape
Dim rngCopyFrom As Range
Set rngCopyFrom = ActiveSheet.Range("R55", "T75")
Set pptApp = New PowerPoint.Application
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Open(Filename:="C:\Users\seleveafe\Desktop\XXXXXX.pptm")
With pptPres.Slides(1) 'first slide
For Each pptShape In .Shapes
If pptShape.HasChart Then 'first chart
Exit For
End If
Next pptShape
If Not pptShape Is Nothing Then
pptShape.Chart.ChartData.Activate
With rngCopyFrom
pptShape.Chart.ChartData.Workbook.Worksheets(1).Range("a2") _
.Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
pptShape.Chart.ChartData.Workbook.Close
End If
End With
Set pptApp = Nothing
Set pptPres = Nothing
Set pptShape = Nothing
Set rngCopyFrom = Nothing
End Sub
Edit
To choose which chart to update, for example the second chart, try the following instead...
Option Explicit
Sub MyMacroRätt()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptShape As PowerPoint.Shape
Dim rngCopyFrom As Range
Dim ChartNum As Long
Dim ChartIndex As Long
ChartNum = 2 'second chart
Set rngCopyFrom = ActiveSheet.Range("R55", "T75")
Set pptApp = New PowerPoint.Application
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Open(Filename:="C:\Users\seleveafe\Desktop\XXXXXX.pptm")
With pptPres.Slides(1) 'first slide
ChartIndex = 0
For Each pptShape In .Shapes
If pptShape.HasChart Then
ChartIndex = ChartIndex + 1
If ChartIndex = ChartNum Then
Exit For
End If
End If
Next pptShape
If Not pptShape Is Nothing Then
pptShape.Chart.ChartData.Activate
With rngCopyFrom
pptShape.Chart.ChartData.Workbook.Worksheets(1).Range("a2") _
.Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
pptShape.Chart.ChartData.Workbook.Close
End If
End With
Set pptApp = Nothing
Set pptPres = Nothing
Set pptShape = Nothing
Set rngCopyFrom = Nothing
End Sub