Notifications
Clear all

MACRO PARA SALVAR PLANILHA EM PPT

2 Posts
1 Usuários
0 Reactions
2,215 Visualizações
(@sandroh)
Posts: 0
New Member
Topic starter
 

Boa tarde pessoal,
Preciso de uma macro que salve uma planilha excel (com gráficos e imagens) em powerpoint.

Alguém sabe como posso fazer isso?

Grato.

 
Postado : 19/06/2015 1:37 pm
(@sandroh)
Posts: 0
New Member
Topic starter
 

Fala galera, eu encontrei a solução, segue o código comentado caso alguém esteja com a mesma duvida:

Option Explicit
'Você precisa incluir a referência (Ferramentas | Referências) para a biblioteca Microsoft PowerPoint Object Library

Sub CriarPPT()
On Error GoTo Err_Handler
Application.ScreenUpdating = False 'Executa macro em segundo plano
Sheets("PPT").Select 'Seleciona aba PPT
Call CriarArquivo("PPT") 'Chama função PPT

Exit Sub
Err_Handler: 'Em caso de erro exiba
MsgBox Err.Description, vbExclamation
End Sub

Sub CriarArquivo(ByVal sSalvarTipo As String)
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
Dim shComGraf As Worksheet
Dim objChartObject As ChartObject
Dim objChart As Chart
Dim iContadorSlide As Long
Dim sSalvarComo As String
Dim iTipoSave As Integer

'Cria o Powerpoint
Set pptApp = New PowerPoint.Application
pptApp.Visible = msoTrue

'Cria o novo arquivo do Power Point, ou seja, a Apresentação
Set pptPres = pptApp.Presentations.Add
Set pptPres = pptApp.ActivePresentation

'Define o modo de visualização
'pptApp.ActiveWindow.ViewType = ppViewSlide

iContadorSlide = 0
'Salva o arquivo ppt com o nome especificado
sSalvarComo = ThisWorkbook.Path & "ApresentaEficiencia"

iTipoSave = ppSaveAsDefault

'=================================================================================
'=== Copia os gráficos das planilhas ===
'=================================================================================

'Define a planilha que contém os gráficos
Set shComGraf = ThisWorkbook.Worksheets("PPT")

'Verifica se existe gráficos para copiar
If shComGraf.ChartObjects.Count > 0 Then
Dim graf As Integer 'Cria váriavel graf
graf = 1 'Atribui o valor 1 a variavel graf
For Each objChartObject In shComGraf.ChartObjects
iContadorSlide = iContadorSlide + 1
Set objChart = objChartObject.Chart
Set pptSld = pptPres.Slides.Add(iContadorSlide, 12)
pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
With objChart
'Copia o gráfico como figura
ActiveSheet.Shapes.Range(Array(graf)).Select 'Cria um array com o número
'de graficos onde cada grafico tem um 1 como nome
Selection.Copy 'Copia grafico em questão
'Aqui é feita a cópia do gráfico no Slide
pptSld.Shapes.Paste.Select 'Cola gráfico no slide
'Centraliza grafico no slide
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, msoTrue
End With
graf = graf + 1 'Atribui +1 a variavel graf
Next objChartObject
End If

'=================================================================================

'Salva apresentação PowerPoint application
pptPres.SaveAs sSalvarComo, iTipoSave

'Encerra aplicativo PowerPoint
'pptPres.Close
'pptApp.Quit

shComGraf.Range("A1").Select

Set shComGraf = Nothing
Set objChart = Nothing
Set pptSld = Nothing
Set pptPres = Nothing
Set pptApp = Nothing

MsgBox "Processo concluído", vbInformation

End Sub

Abraço!

 
Postado : 22/06/2015 7:43 am