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
Related
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
Is there a way such that i can copy and paste multiple charts that are grouped in four as shown below from excel to my existing powerpoint slides 28 and slides 29? The name of the groups are group 16 for the left group, group 17 for the right group. I have tried to use Chrt.CopyPicture but it only copies charts separately to the slides instead of a group like the one outline on the 4 charts shown on the left side of the picture below. By the way, my only code only copies charts individually to slide 28.
Sub ExportChartsTopptSingleWorksheet()
'Declare PowerPoint Variables
Dim PPTApp As Object
Dim PPTPres As Object
Dim PPTShape As Object
Dim mySlide, myslide2 As Object
'Declare Excel Variables
Dim Chrt As ChartObject
If PPTApp Is Nothing Then _
Set PPTApp = CreateObject(class:="PowerPoint.Application")
On Error GoTo 0
PPTApp.Visible = True
'Create new presentation in the PowerPoint application.
Set PPTPres = PPTApp.Presentations.Open(Filename:="\\fab2crp-nas1\home22\kkang2\Profile\Desktop\myassignment3\mypresentationsample.pptx")
Set mySlide = PPTPres.Slides.Add(28, 1)
'Loop through all the CHARTOBJECTS in the ACTIVESHEET.
For Each Chrt In ActiveSheet.ChartObjects
'Copy the Chart
Chrt.CopyPicture '<------ method copy fail error here
'paste all the chart on to exisitng ppt slide 28
mySlide.Shapes.Paste
Next Chrt
End Sub
Currently, charts are copied individually to ppt slides
Expected
This worked for me.
Sub ExportChartsTopptSingleWorksheet()
Const PER_ROW As Long = 2 'charts per row in PPT
Const T_START As Long = 40 'start chart top
Const L_START As Long = 40 'start chart left
Dim PPTApp As Object
Dim PPTPres As Object
Dim PPTShape As Object
Dim mySlide, myslide2 As Object, i As Long
Dim Chrt As ChartObject, T As Long, L As Long
If PPTApp Is Nothing Then _
Set PPTApp = CreateObject(class:="PowerPoint.Application")
PPTApp.Visible = True
Set PPTPres = PPTApp.Presentations.Add()
Set mySlide = PPTPres.Slides.Add(1, 1)
i = 0
For Each Chrt In ActiveSheet.ChartObjects
Chrt.Chart.CopyPicture
i = i + 1
'work out the top/left values
T = T_START + (Application.Floor((i - 1) / PER_ROW, 1)) * Chrt.Height
L = L_START + ((i - 1) Mod PER_ROW) * Chrt.Width
With mySlide.Shapes
.Paste
.Item(.Count).Top = T
.Item(.Count).Left = L
End With
Next Chrt
End Sub
I have built a workbook to facilitate the creation of a monthly report presentation I am in charge of. The workbook has some data sheets, some processing sheets and then numbered sheets which contain the charts I need to paste to the corresponding slide. So far, I've built the VBA for opening the PowerPoint template and looping through each excel sheet, and discriminating which sheet names are numeric, and then activating the corresponding slide on the powerpoint template.
Unlike other solutions to similar problems I've found, I'd like to copy all charts from each numbered sheet to each slide at a time, as they are different in shape, quantities and disposition for each sheet/slide. I've mostly only found people copying one chart at a time and pastying as image, which will also not work for me (I need to fine tune data labels and position on the final slide). Any hints as to how could I achieve that?
Here's what my code looks like so far:
Sub CriarSlides()
Dim pptApp As Powerpoint.Application
Dim pptPres As Powerpoint.Presentation
Dim strFileToOpen As Variant
Dim strFileName As String, Hosp As String
Dim datawb As Workbook
Dim xlsCounter As Integer, xlsSlide As Integer
Set datawb = ThisWorkbook
strFileToOpen = Application.GetOpenFilename _
FileFilter:="Powerpoint Files *.pptx (*.pptx),")
If strFileToOpen = False Then
Exit Sub
Else
Set pptApp = New Powerpoint.Application
pptApp.Visible = True
pptApp.Presentations.Open Filename:=strFileToOpen, ReadOnly:=msoFalse, Untitled:=msoTrue
Set pptPres = pptApp.Presentations(1)
End If
For xlsCounter = datawb.Worksheets.Count To 1 Step -1
If IsNumeric(datawb.Worksheets(xlsCounter).Name) Then
xlsSlide = datawb.Worksheets(xlsCounter).Name
' This is the problematic part
Debug.Print xlsSlide
End If
Next xlsCounter
End Sub
With the following modified code you can paste the chart-objects of each sheet in the corresponding slide:
Sub CriarSlides()
Dim pptApp As PowerPoint.Application, pptPres As PowerPoint.Presentation
Dim strFileToOpen As Variant, sh As Worksheet, ch As ChartObject
strFileToOpen = Application.GetOpenFilename(FileFilter:="Powerpoint Files *.pptx (*.pptx),")
If strFileToOpen = False Then Exit Sub
Set pptApp = New PowerPoint.Application
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Open(fileName:=strFileToOpen, ReadOnly:=msoFalse)
For Each sh In ThisWorkbook.Sheets
If IsNumeric(sh.name) Then
For Each ch In sh.ChartObjects
ch.Copy
With pptPres.Slides(CLng(sh.name)).Shapes.Paste
.Top = ch.Top
.Left = ch.Left
.Width = ch.Width
.Height = ch.Height
End With
Next
End If
Next
End Sub
So I am trying to paste a column into powerpoint slide notes but it only grabs one cell and pastes it into the first slide and will not go to the next slide and paste the next cell into the notes of the 2nd slide.
Sub Notes()
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim PPTShape As PowerPoint.Shape
Dim strNotes As String
' Amended Dim Sh As Shape to...
Dim Sh As PowerPoint.Shape
'launch powerpoint application
Set PPTApp = New PowerPoint.Application
PPTApp.Activate
'open powerpoint presentation for macmahon off the intranet
Set PPTPres = PPTApp.Presentations.Open("C:\Users)
Sheets("Raw Data").Select
Range("M2:M26").Select
Set PPTSlide = PPTPres.Slides(1)
On Error GoTo errHandler
Do While ActiveCell.Value <> ""
ActiveCell.Copy
With PPTSlide
If PPTSlide.NotesPage.Shapes.Count = 0 Then 'If no shapes to take Notes then add a shape first
PPTSlide.NotesPage.Shapes.AddShape msoShapeRectangle, 0, 0, 0, 0
Sh = PPTSlide.NotesPage.Shapes(1)
'Code change here - did not recognize Sh.TextFrame.TextRange.Text.Paste
'So, I set the object text to value of the active cell and seemed to do the trick
Sh.TextFrame.TextRange.Text = ActiveCell.Value
Else 'has shapes, so see if they take text
For Each Sh In PPTSlide.NotesPage.Shapes
If Sh.HasTextFrame Then
'Code change here - did not recognize Sh.TextFrame.TextRange.Text.Paste
'So, I set the object text to value of the active cell and seemed to do the trick
Sh.TextFrame.TextRange.Text = ActiveCell.Value
End If
Next Sh
End If
End With
Set PPTSlide = PPTPres.Slides.Add(PPTPres.Slides.Count + 1, ppLayoutText)
ActiveCell.Offset(1, 0).Select
Loop
Exit Sub
errHandler:
MsgBox Err.Number & vbTab & Err.Description, vbCritical, "Error"
End Sub
You are setting a fixed reference to slide 1 in this line:
Set PPTSlide = PPTPres.Slides(1)
Instead of that, wrap the code to copy and paste the cell content in a For...Next loop which loops through your desired slides. For example, to loop through all slides in the presentation:
For Each PPTSlide In PPTPres.Slides
With PPTSlide
' Do the things you need to do on this slide
End With
Next
Or manage a pre-defined range of slides:
Dim lSlideIndex As Long
For lSlideIndex = 2 to 5 ' Process slides 2 to 5
With PPTPres.Slides(lSlideIndex)
' Do the things you need to do on this slide
End With
Next
I have several Powerpoint files being generated everymonth, these files have several charts with embedded excel tables behind them, for some month some series(columns) are full of zeros, I would like to find a Powerpoint Macro that goes into each chart looks on the embedded excel and deletes columns that are all zeros.
Now I have the code to do it in excel
Sub DeleteColumns()
Dim LR As Long, LC As Long
Dim i As Long, j As Long
LR = Cells.Find(What:="*", SearchDirection:=xlPrevious,SearchOrder:=xlByRows).Row
LC = 52
For j = LC To 1 Step -1
For i = LR To 1 Step -1
If Cells(i, j).Value = 0 Then
Columns(j).Delete
Exit For
End If
Next i
Next j
End Sub
And its working, I just dont know how to reference all the charts inside the powerpoint and then target the embedded excel tables behing them.
Many Thanks
You can expose all the underlying excel chart like so.
I'm not sure of how you are looking to remove the zero columns so suggest you add this in at the spot highlighted below.
Sub ChangeChartData()
Dim pptChart As Chart
Dim pptChartData As ChartData
Dim xlWorkbook 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
Set pptWorkbook = pptChartData.Workbook
'your delete code here
pptWorkbook.Close True
End If
Next
Next
Set pptWorkbook = Nothing
Set pptChartData = Nothing
Set pptChart = Nothing
End Sub