Excel to powerpoint VBA (2 sets of codes)

[tennisbuck]

Hi Board,

I'm new to VBA but in my limited expereinces it has been very helpful. I have 2 sets of VBA code that I need to combined these 2 sets of VBA.

The first code selects the powerpoint deck that I want the excel graph to be dropped in and has the placement and size. This works great but the problem is that I have mutiple graphs on each tab in excel and I can only select one graph per one slide.

Option Explicit
'---------------------------------------------------------------------------------------
' Procedure : GetFileName
' Author
' Date : 7/29/2013
' Purpose :
'---------------------------------------------------------------------------------------
'
Function GetFileName() As String

Dim strNewFN As String

On Error GoTo GetFileName_Error
'FileFilter:="Excel Files (*.xls), *.xls", Title:="Please select a file"
strNewFN = Application.GetOpenFilename()
GetFileName = strNewFN
On Error GoTo 0
Exit Function
GetFileName_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetFileName of Module Module3 On Line " & Erl
End Function

' Code to export data, charts, etc.
'---------------------------------------------------------------------------------------
' Procedure : PopulatePowerPoint
' Author :
' Date : 7/29/2013
' Purpose :
'---------------------------------------------------------------------------------------
'
Function PopulatePowerPoint()
'Add a reference to the Microsoft PowerPoint Library by:
'1. Go to Tools in the VBA menu
'2. Click on Reference
'3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay
'First we declare the variables we will be using
'Dim newPowerPoint As PowerPoint.Application


Dim activeSlide As PowerPoint.Slide
Dim strPlaceHolder As String
Dim strPowerPointFileName As String
Dim wsWorksheets As Excel.Worksheet
Dim choCharts As Excel.ChartObject
Dim ppPowerPointApp As PowerPoint.Application


On Error GoTo PopulatePowerPoint_Error
Set ppPowerPointApp = CreateObject("PowerPoint.Application")
ppPowerPointApp.Visible = msoTrue

strPowerPointFileName = GetFileName
ppPowerPointApp.Presentations.Open strPowerPointFileName


Sheets("UM Analysis").Activate
Set wsWorksheets = ActiveWorkbook.Sheets("UM Analysis")
For Each choCharts In wsWorksheets.ChartObjects

If choCharts.Chart.Name = "UM Analysis" Then

'Add a new slide where we will paste the chart

ppPowerPointApp.ActiveWindow.View.GotoSlide (6)

Set activeSlide = ppPowerPointApp.ActivePresentation.Slides(6)

'Copy the chart and paste it into the PowerPoint as a Metafile Picture
choCharts.Select
ActiveChart.ChartArea.Copy
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select


' 'Adjust the positioning of the Chart on Powerpoint Slide
ppPowerPointApp.ActiveWindow.Selection.ShapeRange.Left = 215
ppPowerPointApp.ActiveWindow.Selection.ShapeRange.Top = 225
ppPowerPointApp.ActiveWindow.Selection.ShapeRange.Width = 300
ppPowerPointApp.ActiveWindow.Selection.ShapeRange.Height = 495

End If
'-----------------------
If choCharts.Chart.Name <> "UM Analysis Chart2" Then


ppPowerPointApp.ActiveWindow.View.GotoSlide (5)

Set activeSlide = ppPowerPointApp.ActivePresentation.Slides(5)

'Copy the chart and paste it into the PowerPoint as a Metafile Picture
choCharts.Select
ActiveChart.ChartArea.Copy
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select


' 'Adjust the positioning of the Chart on Powerpoint Slide
ppPowerPointApp.ActiveWindow.Selection.ShapeRange.Left = 500
ppPowerPointApp.ActiveWindow.Selection.ShapeRange.Top = 325
ppPowerPointApp.ActiveWindow.Selection.ShapeRange.Width = 250
ppPowerPointApp.ActiveWindow.Selection.ShapeRange.Height = 468

End If
'------------------------
Next


On Error GoTo 0
CleanUp:
Set activeSlide = Nothing
Set ppPowerPointApp = Nothing

Exit Function
PopulatePowerPoint_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure PopulatePowerPoint of Module Module3 On Line " & Erl
GoTo CleanUp

End Function


This next set code is suppose to be able to select one chart at a time. How would I combine these 2 sets of VBA code into one.


Sub ChartsAndTitlesToPresentation()</SPAN></PRE>
' Set a VBE reference to Microsoft PowerPoint Object Library</SPAN></PRE>
</PRE>
Dim PPApp As PowerPoint.Application</SPAN></PRE>
Dim PPPres As PowerPoint.Presentation</SPAN></PRE>
Dim PPSlide As PowerPoint.Slide</SPAN></PRE>
Dim PresentationFileName As Variant</SPAN></PRE>
Dim SlideCount As Long</SPAN></PRE>
Dim iCht As Integer</SPAN></PRE>
Dim sTitle As String</SPAN></PRE>
</PRE>
' Reference existing instance of PowerPoint</SPAN></PRE>
Set PPApp = GetObject(, "Powerpoint.Application")</SPAN></PRE>
' Reference active presentation</SPAN></PRE>
Set PPPres = PPApp.ActivePresentation</SPAN></PRE>
PPApp.ActiveWindow.ViewType = ppViewSlide</SPAN></PRE>
</PRE>
For iCht = 1 To ActiveSheet.ChartObjects.Count</SPAN></PRE>
With ActiveSheet.ChartObjects(iCht).Chart</SPAN></PRE>
</PRE>
' get chart title</SPAN></PRE>
If .HasTitle Then</SPAN></PRE>
sTitle = .ChartTitle.Text</SPAN></PRE>
Else</SPAN></PRE>
sTitle = ""</SPAN></PRE>
End If</SPAN></PRE>
</PRE>
' remove title (or it will be redundant)</SPAN></PRE>
.HasTitle = False</SPAN></PRE>
</PRE>
' copy chart as a picture</SPAN></PRE>
.CopyPicture _</SPAN></PRE>
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture</SPAN></PRE>
</PRE>
' restore title</SPAN></PRE>
If Len(sTitle) > 0 Then</SPAN></PRE>
.HasTitle = True</SPAN></PRE>
.ChartTitle.Text = sTitle</SPAN></PRE>
End If</SPAN></PRE>
End With</SPAN></PRE>
</PRE>
' Add a new slide and paste in the chart</SPAN></PRE>
SlideCount = PPPres.Slides.Count</SPAN></PRE>
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutTitleOnly)</SPAN></PRE>
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex</SPAN></PRE>
With PPSlide</SPAN></PRE>
' paste and select the chart picture</SPAN></PRE>
.Shapes.Paste.Select</SPAN></PRE>
' align the chart</SPAN></PRE>
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True</SPAN></PRE>
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True</SPAN></PRE>
.Shapes.Placeholders(1).TextFrame.TextRange.Text = sTitle</SPAN></PRE>
End With</SPAN></PRE>
</PRE>
Next</SPAN></PRE>
</PRE>
' Clean up</SPAN></PRE>
Set PPSlide = Nothing</SPAN></PRE>
Set PPPres = Nothing</SPAN></PRE>
Set PPApp = Nothing</SPAN></PRE>
</PRE>
End Sub</SPAN></PRE>

 

[tennisbuck]

Also the excel spreadsheet has mutiple tabs with charts.

 

[tennisbuck]

any suggestions?

 

[tennisbuck]

Hi,

Do I need to provide more info?