I have written the code and it is updating data in chartdata of ppt but entire range from external excel file is not being displayed when chart is produced.
So from code is pulling data from excel and pasting in chartdata of ppt but when chart is produced is shows only range a1:b4 whereas actual range is a1 : c4
Sub openppt()
Dim DestinationPPT As String
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim cht As PowerPoint.Chart
Dim chtData As PowerPoint.ChartData
Dim startcell As Range
Dim lastrow As Long
Dim lastcol As Long
Dim ws As Worksheet
Set PowerPointApp = CreateObject("PowerPoint.Application")
PowerPointApp.Visible = True
DestinationPPT = "C:\Users\alex.samuel\Desktop\assignment\VBA Training.pptx"
PowerPointApp.Presentations.Open (DestinationPPT)
Set myPresentation = PowerPointApp.Presentations("VBA Training.pptx")
'Assume we have only one slide, at slide 1:
Set sld = myPresentation.Slides(1)
'Assume the Chart is the second shape, modify if needed
Set shp = sld.Shapes("Chart 29")
'Handle the chart
Set cht = shp.Chart
'Handle the CharttData
Set chtData = cht.ChartData
'Set Object
Set ws = Sheet1
Set startcell = Range("a1")
'Find last row and column in data
lastrow = ws.Cells(ws.Rows.Count, startcell.Column).End(xlUp).Row
lastcol = ws.Cells(startcell.Row, ws.Columns.Count).End(xlToLeft).Column
'select dynamic range of data
ws.Range(startcell, ws.Cells(lastrow, lastcol)).Select
'copy dynamic range
ws.Range(startcell, ws.Cells(lastrow, lastcol)).Copy
'Open & minimize the ChartData, you don't need to see it, but it must be OPEN to edit it
chtData.Activate
ActiveSheet.Range("a1").Select
ActiveSheet.Paste
ActiveSheet.setdatasource Source:=ws.Range("a1:c4")`enter code here`
End Sub
Related
I'm having trouble pasting values from excel into a table in ppt. It gives me error in this last line, can anybody figure out why and how it can be improved?
Dim ppt As PowerPoint.Application
Dim pres As PowerPoint.Presentation
Dim sl As PowerPoint.Slide
Dim sh As PowerPoint.Shape
Dim sh1 As PowerPoint.Shape
Dim r As Range
Dim filterRange As Range
Dim copyRange As Range
Dim lastRow As Long
Set ppt = New PowerPoint.Application
Set pres = ppt.Presentations.Open(ThisWorkbook.Path & "\Edenred_ProjectStatus_Saxo.pptx")
Set sl = pres.Slides(1)
Set sh1 = sl.Shapes("Table 3")
ThisWorkbook.Sheets("Action&Open_Point").Range("H1").AutoFilter field:=1, Criteria1:="Y"
lastRow = ThisWorkbook.Sheets("Action&Open_Point").Range("D" &
ThisWorkbook.Sheets("Action&Open_Point").Rows.Count).End(xlUp).Row
Set copyRange = ThisWorkbook.Sheets("Action&Open_Point").Range("D2:D" & lastRow)
ActiveWorkbook.Worksheets("Action&Open_Point").UsedRange.Font.Underline = False
copyRange.SpecialCells(xlCellTypeVisible).Copy
**sh1.TextFrame.TextRange.Paste**
It runs until "copy" but then it does not paste it on ppt. the error says it is out of range
I am fairly new at this but am beating my head on this. I have a basic functioning code where it opens up the PP and inputs the data from my excel sheets. But it auto centers each sheet's array and the text looks very small. I want to be able to basically make the text larger on different scales, and reposition a couple arrays on each sheet as I see fit. I know the "populate our arrays" is kind of truncated, so I would assume I would need to break that apart to apply the custom dimensions to each sheet. Thank you so much in advance.
Sub ExportMultipleRangeToPowerPoint_Method1()
'Declare PowerPoint Variables
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
'Opens a new PowerPoint presentation based on template and pastes data into Slide 2 of Powerpoint from Excel
Dim PPapp As PowerPoint.Application, PPpres As PowerPoint.Presentation, PPslide As PowerPoint.Slide, PPShape As Object
Dim XLws As Worksheet
'Declare Excel Variables
Dim ExcRng As Range
Dim RngArray As Variant
Dim ShtArray As Variant
'Populate our arrays
RngArray = Array("A1:E16", "C2:E6", "B2:D6")
ShtArray = Array("Summary", "Sheet2", "Sheet3")
'Create a new instance of PowerPoint
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
'Create a new Presentation
Set PPTPres = PPTApp.Presentations.Add
'Loop through the range array, create a slide for each range, and copy that range on to the slide.
For x = LBound(RngArray) To UBound(RngArray)
'Set a reference to the range
Set ExcRng = Worksheets(ShtArray(x)).Range(RngArray(x))
'Copy the range
ExcRng.Copy
'Create a new Slide
Set PPTSlide = PPTPres.Slides.Add(x + 1, ppLayoutBlank)
'Paste the range in the slide
PPTSlide.Shapes.Paste
Next x
End Sub
Try
' width, height, left, top
ImgArray = Array("300,300,100,100", _
"200,200,200,200", _
"150,150,150,150")
'Create a new instance of PowerPoint
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
'Create a new Presentation
Set PPTPres = PPTApp.Presentations.Add
'Loop through the range array, create a slide for each range, and copy that range on to the slide.
Dim x
For x = LBound(RngArray) To UBound(RngArray)
'Set a reference to the range
Set ExcRng = Worksheets(ShtArray(x)).Range(RngArray(x))
'Copy the range
ExcRng.Copy
'Create a new Slide
Set PPTSlide = PPTPres.Slides.Add(x + 1, ppLayoutBlank)
'Paste the range in the slide
ar = Split(ImgArray(x), ",")
With PPTSlide.Shapes.PasteSpecial(ppPasteOLEObject)
.Width = ar(0)
.Height = ar(1)
.Left = ar(2)
.Top = ar(3)
End With
Next x
I currently have a larger table in excel that I am trying to copy/paste into an existing PPT doc. Since the table is too long to fit on one slide I'm trying to have it take every 15 rows and paste on a new slide. The code below works, but it is set up to take a specified range for each slide. I've tried several other ways, but they all end up opening the PPT doc and essentially doing nothing.
Sub ExcelToPowerPoint()
Dim PPapp As PowerPoint.Application
Dim PPpres As PowerPoint.Presentation
Dim PPslide As PowerPoint.Slide
Dim Xlws As Worksheet
Dim rng As Range
Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long
Dim shp As Object
Dim i As Long
Dim j As Integer
Set Xlws = ActiveSheet
Set PPapp = New PowerPoint.Application
Set PPpres = PPapp.Presentations.Open("insert name of doc here")
PPapp.ActivePresentation.Slides(4).Select
PPapp.Activate
PPapp.Visible = True
'List of PPT Slides to Paste to
MySlideArray = Array(4, 5, 6)
'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheets("Template").Range("B1:K16"), Sheets("Template").Range("B16:K31"), Sheets("Template").Range("B31:K45"))
'Loop through Array data
For x = LBound(MySlideArray) To UBound(MySlideArray)
'Copy Excel Range
MyRangeArray(x).Copy
On Error Resume Next
Set shp = PPpres.Slides(MySlideArray(x)).Shapes.PasteSpecial(ppPasteEnhancedMetafile)
shp.Shapes.PasteSpecial ppPasteEnhancedMetafile
Set mySlide = PPapp.ActiveWindow.Selection.ShapeRange
mySlide.Left = 30
mySlide.Top = 85
mySlide.Height = 150
mySlide.Width = 900
Next x
End Sub
I think this is what you want.
Option Explicit
Sub Test()
Dim lastrow As Long
Dim row1 As Long
Dim row2 As Long
Dim dataRange As Range
With Sheets("Template")
' Get last row on sheet
lastrow = .Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).row
' Copy data 15 rows at a time
row1 = 1
Do While row1 < lastrow
row2 = row1 + 14
If row2 > lastrow Then
row2 = lastrow
End If
' Copy data range
.Range("B" & row1 & ":K" & row2).Copy
'*********************************
'* Paste data to PowerPoint here *
'*********************************
row1 = row2 + 1
Loop
End With
End Sub
P.S. You might want to read this How to avoid using Select in Excel VBA
My code now is pasting 1 chart onto 1 slide. How do I make it paste all of the charts on Sheet1 (2 charts in Sheet1) to Slide1 and all of the charts (2 charts in Sheet2) on Sheet2 to Slide2, and so on... I tried increasing the count but the code fails.
Dim ppt As PowerPoint.Application
Dim ppTPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
Dim pptCL As PowerPoint.CustomLayout
Dim pptShp As PowerPoint.Shape
Dim chtt As Chart
Dim ws As Worksheet
Dim i As Long
'Optimise execution of code
Application.ScreenUpdating = False
'Get the PowerPoint Application object:
Set ppt = CreateObject("PowerPoint.Application")
ppt.Visible = msoTrue
Set ppTPres = ppt.Presentations.Add
'Get a Custom Layout:
For Each pptCL In ppTPres.SlideMaster.CustomLayouts
If pptCL.Name = "Title and Content" Then Exit For
Next pptCL
For Each ws In ActiveWorkbook.Worksheets
For i = 1 To ws.ChartObjects.Count
Set pptSld = ppTPres.Slides.AddSlide(ppTPres.Slides.Count + 1, pptCL)
pptSld.Select
For Each pptShp In pptSld.Shapes.Placeholders
If pptShp.PlaceholderFormat.Type = ppPlaceholderObject Then Exit For
Next pptShp
Set chtt = ws.ChartObjects(i).Chart
chtt.ChartArea.Copy
ppt.Activate
pptShp.Select
ppt.Windows(1).View.Paste
Next i
Next ws
'Optimise execution of code
Set chtt = Nothing
Set pptSld = Nothing
Application.ScreenUpdating = True
'Clear clipboard
Application.CutCopyMode = False
I want to build a macro that connects our Excel-Data-Sheet with our Reporting-Powerpoint-Presentation.
So I have this named Range ("A") selected and copied.
Then I want to paste the data into a shape in Powerpoint which has the same name as my Range ("A").
Sub SyncWithPPT()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptShape As PowerPoint.Shape
Set pptApp = New PowerPoint.Application
pptApp.Visible = msoTrue
Set pptPres = pptApp.presentations.Open("workingPath")
ActiveWorkbook.Names("A").RefersToRange.Select
Selection.Copy
Set pptShape = pptPres.Slides("anySlide").Shapes("A")
pptShape.Table.cell(1, 1).Shape.TextFrame.TextRange.Paste 'Here it won't paste correctly
End Sub
Everything works just fine, except the pasting. When I paste the selection everything is pasted into cell(1, 1).But I want to copy each cell into a different cell. Like it does when you paste with STRG + V.
Any help would be really appreciated.
This worked for me (Office 2007)...
Sub Tester()
Dim ppt, sld
'presentation is already open...
Set ppt = GetObject(, "powerpoint.application")
Set sld = ppt.activepresentation.slides(1)
ActiveSheet.Range("A1:B2").Copy
sld.Shapes(1).Table.Cell(1, 1).Select
ppt.ActiveWindow.View.Paste
Set sld = Nothing
Set ppt = Nothing
End Sub
'this is how to extract each cell information
'assuming that ppt communication is already done.
Dim n As Integer, j As Integer
Dim ultimaFila As Long
j = 1 'columna
ultimaFila = Range("A65536").End(xlUp).Row
For n = 1 To ultimaFila
pptShape.Table.cell(n, j).Value = Application.Workbooks("Book1").Worksheets("Sheet1").Cells(n, j).Value
Next n
End Sub