jamtay317
12-19-2014, 06:16 AM
Hello and thank you for reading this! I have created a macro to export several charts from excel to Power Point. It works Great with PC.
Dim wkbk As Workbook
Dim pptApp As powerpoint.Application
Dim pptStart As powerpoint.Application
Dim pptPres As powerpoint.Presentation
Dim sld As slide
Dim fyleName As String
Dim cht As Shape
Dim ws As Worksheet
Dim txt As powerpoint.TextFrame
Dim shp As powerpoint.Shape
Dim oLayout As powerpoint.CustomLayout
Dim i As Integer
Sub ExportCharts()
If MsgBox("This may take several minutes, you with to proceed?", vbYesNo) _
= vbNo Then Exit Sub
Set wkbk = ActiveWorkbook
Set ws = ThisWorkbook.Sheets("Dash")
Set pptApp = CreateObject("Powerpoint.Application")
Set pptPres = pptApp.Presentations.Add
Set sld = pptPres.Slides.Add(1, ppLayoutText)
'Creating Title Page
With sld.Shapes.Title.TextFrame.TextRange
.Font.Size = 66
.Text = "Chicago Housing Data Areas"
End With
With sld.Shapes(2)
.TextFrame.TextRange.Text = "Wells Fargo"
.TextEffect.FontSize = 60
.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
End With
x = 2
Set sld = Nothing
Set oLayout = pptPres.Designs(1).SlideMaster.CustomLayouts(7)
i = 1
Application.ScreenUpdating = False
Do Until i = ws.Shapes.Count + 1
Set cht = ws.Shapes("Chart" & i)
cht.Select
cht.Copy
Set sld = pptPres.Slides.AddSlide(x, oLayout)
On Error GoTo here
sld.Shapes.PasteSpecial ppPasteMetafilePicture
On Error GoTo 0
' Stop
If i = ws.Shapes.Count Then
' sld.Shapes.Paste
End If
With sld.Shapes.Item(1) 'assume a blank slide with one image added only
'.Select
.Height = 530
.Width = 750
.Left = 100
.Top = 10
End With
'Stop
x = x + 1
Set sld = Nothing
i = i + 1
'If i = 65 Then Stop
Loop
Set cht = Nothing
pptApp.Visible = True
Exit Sub
Application.ScreenUpdating = False
here:
Do Until g = 300 'give time to Catch up
g = g + 1
Loop
'On Error Resume Next
If i = ws.Shapes.Count Then _
On Error Resume Next
Resume
End Sub
All help is appreciated. thank you!
Dim wkbk As Workbook
Dim pptApp As powerpoint.Application
Dim pptStart As powerpoint.Application
Dim pptPres As powerpoint.Presentation
Dim sld As slide
Dim fyleName As String
Dim cht As Shape
Dim ws As Worksheet
Dim txt As powerpoint.TextFrame
Dim shp As powerpoint.Shape
Dim oLayout As powerpoint.CustomLayout
Dim i As Integer
Sub ExportCharts()
If MsgBox("This may take several minutes, you with to proceed?", vbYesNo) _
= vbNo Then Exit Sub
Set wkbk = ActiveWorkbook
Set ws = ThisWorkbook.Sheets("Dash")
Set pptApp = CreateObject("Powerpoint.Application")
Set pptPres = pptApp.Presentations.Add
Set sld = pptPres.Slides.Add(1, ppLayoutText)
'Creating Title Page
With sld.Shapes.Title.TextFrame.TextRange
.Font.Size = 66
.Text = "Chicago Housing Data Areas"
End With
With sld.Shapes(2)
.TextFrame.TextRange.Text = "Wells Fargo"
.TextEffect.FontSize = 60
.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
End With
x = 2
Set sld = Nothing
Set oLayout = pptPres.Designs(1).SlideMaster.CustomLayouts(7)
i = 1
Application.ScreenUpdating = False
Do Until i = ws.Shapes.Count + 1
Set cht = ws.Shapes("Chart" & i)
cht.Select
cht.Copy
Set sld = pptPres.Slides.AddSlide(x, oLayout)
On Error GoTo here
sld.Shapes.PasteSpecial ppPasteMetafilePicture
On Error GoTo 0
' Stop
If i = ws.Shapes.Count Then
' sld.Shapes.Paste
End If
With sld.Shapes.Item(1) 'assume a blank slide with one image added only
'.Select
.Height = 530
.Width = 750
.Left = 100
.Top = 10
End With
'Stop
x = x + 1
Set sld = Nothing
i = i + 1
'If i = 65 Then Stop
Loop
Set cht = Nothing
pptApp.Visible = True
Exit Sub
Application.ScreenUpdating = False
here:
Do Until g = 300 'give time to Catch up
g = g + 1
Loop
'On Error Resume Next
If i = ws.Shapes.Count Then _
On Error Resume Next
Resume
End Sub
All help is appreciated. thank you!