tennisbuck
New Member
- Joined
- Apr 29, 2013
- Messages
- 23
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>
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>