none
EXPORTAR GRAFICO DO EXCEL PARA POWERPOINT (CHART EXCEL TO PPT) RRS feed

  • Pergunta

  • Olá pessoal tudo bom?

    Estou com um código em VBA de uma macro que exporta todos os graficos das planilhas existentes da pasta de trabalho do Excel para PPT (POWERPOINT)

    Quando eu executo a macro, automaticamente ela exporta para uma apresentação de slide (powerpoint) existente e começa a partir do slide 10.

    A 1º vez que executo, ela funciona normalmente, 1 grafico para 1 slide e fica assim: slide 10 - 1º grafico, slide 11º segundo grafico, slide 12º terceiro grafico, slide 14º quarto grafico, slide 15º quinto grafico...

    Porém, na 2º vez que eu executo a macro selecionando outros 5 graficos para exportar, ele exporta na mesma ordem, ficando: slide 10º 2 graficos , slide 11º 2 graficos e assim adiante..

    eu preciso que quando eu executar a macro pela segunda vez ele continuar: a partir do 15º slide. ficando slide 16º 1 grafico, slide 17º 1 grafico e assim por diante.

    esse é o código que estou utilizando.

    Option Explicit

    'Não esqueca de Declarar as Referencias para o PowerPoint

    'Declarando as Variaveis Necessarias da Aplicação

    Dim pptApp As PowerPoint.Application

    Dim pptPres As PowerPoint.Presentation

    Dim pptSlide As PowerPoint.Slide

    Dim pptSlideCount As Integer

    Dim objCh As Object

    Sub ExportarTeste()

    'Exportas os Gráficos das Planilhas do Excel para o PowerPoint TECBAN

    'By Luiz Vieira Beserra Neto

    'Produção On_going - Capacity Planning

    ' 11 99009-6054

     

    Dim ws As Worksheet

    Dim intChNum As Integer

    Dim objCh As Object

    Dim k As Integer

    'Contar os gráficos incorporados .

    For Each ws In ActiveWorkbook.Worksheets

        intChNum = intChNum + ws.ChartObjects.Count

    Next ws

     

    'Verifique se existem gráfico (integrado ou não) na pasta de trabalho ativa.

    If intChNum + ActiveWorkbook.Charts.Count < 1 Then

    MsgBox "Sorry, there are no charts to export!", vbCritical, "Ops"

    Exit Sub

    End If

    ' Verificando a Existência de um PowerPoint Aberto

        On Error Resume Next

        Set pptApp = GetObject(, "Powerpoint.Application")

            On Error GoTo 0

        If pptApp Is Nothing Then

        ' Abrindo um novo Powerpoint

            Set pptApp = CreateObject("Powerpoint.Application")

            pptApp.Visible = msoCTrue

            Set pptPres = pptApp.Presentations.Open("C:\Users\tbt01713\Desktop\Templates\teste.pptx")

        Else

            Set pptPres = pptApp.ActivePresentation

        End If

        ' Reference active presentation

     

    k = 10

    'Inicar exportação a partir do K=SLIDE:

    'Percorrer todos os gráficos incorporados em todas as planilhas.

    For Each ws In ActiveWorkbook.Worksheets

    For Each objCh In ws.ChartObjects

    Call pptFormat(objCh.Chart, k)

    k = k + 1

     

    Next objCh

    Next ws

     

    'Loop através de todas as folhas de gráfico.

    For Each objCh In ActiveWorkbook.Charts

    Call pptFormat(objCh, k)

    k = k + 2

    Next objCh

     

    'Mostrar o PowerPoint.

    pptApp.Visible = True

    'Limpeza de objetos

    Set pptSlide = Nothing

    Set pptPres = Nothing

    Set pptApp = Nothing

    'Informa ao Usuário que a Macro foi Concluida

    MsgBox "Os gráficos foram exportados com sucesso", vbOKOnly, "Produção Tecban"

    End Sub

     

    Private Sub pptFormat(xlCh As Chart, pptslidenumber As Integer)

     

    'Formats the charts/pictures and the chart titles/textboxes.

     

    'By Luiz Vieira Beserra Neto

    'Produção On_Going

    'Capacity Planning

    Dim pptApp As PowerPoint.Application

    Dim pptSlide As PowerPoint.Slide

    Dim chTitle As String

    Dim j As Integer

     

    On Error Resume Next

     

    'Get the chart title and copy the chart area.

    chTitle = xlCh.ChartTitle.Text

    xlCh.ChartArea.Copy

     

    'Count the slides and add a new one after the last slide.

    pptSlideCount = pptPres.Slides.Count

    Set pptSlide = pptPres.Slides.Add(pptslidenumber, ppLayoutBlank)

     

    On Error Resume Next

    'Paste the chart and create a new textbox.

    pptSlide.Shapes.PasteSpecial ppPasteJPG

    If chTitle <> "" Then

            pptSlide.Shapes.AddTextbox msoTextOrientationHorizontal, 12.5, 20, 694.75, 55.25

        End If

       

    'Format the picture and the textbox.

    For j = 1 To pptSlide.Shapes.Count

    With pptSlide.Shapes(j)

    'Picture position.

    If .Type = msoPicture Then

    .Top = 87.84976

    .Left = 33.98417

    .Height = 422.7964

    .Width = 646.5262

    End If

    'Text box position and formamt.

    If .Type = msoTextBox Then

                    With .TextFrame.TextRange

                        .ParagraphFormat.Alignment = ppAlignCenter

                        .Text = chTitle

                        .Font.Name = "Tahoma (Headings)"

                        .Font.Size = 28

                        .Font.Bold = msoTrue

                    End With

                End If

    End With

    Next j

    End Sub


    • Editado Luizvbeserra sexta-feira, 16 de setembro de 2016 02:10
    sexta-feira, 16 de setembro de 2016 02:04

Todas as Respostas

  • Olá Luiz!

    Sugiro que na linha onde está k = 10 você altere para:

    k = InputBox("Começar no slide:", "Escolha o número do slide para começar a exportação")

    Pois dessa forma, ao rodar a macro, aparecerá uma janela solicitando a partir de qual slide começar a importação.

    O código ficará:

    Option Explicit
    
    'Não esqueca de Declarar as Referencias para o PowerPoint
    
    'Declarando as Variaveis Necessarias da Aplicação
    
    Dim pptApp As PowerPoint.Application
    
    Dim pptPres As PowerPoint.Presentation
    
    Dim pptSlide As PowerPoint.Slide
    
    Dim pptSlideCount As Integer
    
    Dim objCh As Object
    
    Sub ExportarTeste()
    
    'Exportas os Gráficos das Planilhas do Excel para o PowerPoint TECBAN
    
    'By Luiz Vieira Beserra Neto
    
    'Produção On_going - Capacity Planning
    
    ' 11 99009-6054
    
     
    
    Dim ws As Worksheet
    
    Dim intChNum As Integer
    
    Dim objCh As Object
    
    Dim k As Integer
    
    'Contar os gráficos incorporados .
    
    For Each ws In ActiveWorkbook.Worksheets
    
        intChNum = intChNum + ws.ChartObjects.Count
    
    Next ws
    
     
    
    'Verifique se existem gráfico (integrado ou não) na pasta de trabalho ativa.
    
    If intChNum + ActiveWorkbook.Charts.Count < 1 Then
    
    MsgBox "Sorry, there are no charts to export!", vbCritical, "Ops"
    
    Exit Sub
    
    End If
    
    ' Verificando a Existência de um PowerPoint Aberto
    
        On Error Resume Next
    
        Set pptApp = GetObject(, "Powerpoint.Application")
    
            On Error GoTo 0
    
        If pptApp Is Nothing Then
    
        ' Abrindo um novo Powerpoint
    
            Set pptApp = CreateObject("Powerpoint.Application")
    
            pptApp.Visible = msoCTrue
    
            Set pptPres = pptApp.Presentations.Open("C:\Users\tbt01713\Desktop\Templates\teste.pptx")
    
        Else
    
            Set pptPres = pptApp.ActivePresentation
    
        End If
    
        ' Reference active presentation
    
     
    
    k = InputBox("Começar no slide:", "Escolha o número do slide para começar a exportação")
    
    'Inicar exportação a partir do K=SLIDE:
    
    'Percorrer todos os gráficos incorporados em todas as planilhas.
    
    For Each ws In ActiveWorkbook.Worksheets
    
    For Each objCh In ws.ChartObjects
    
    Call pptFormat(objCh.Chart, k)
    
    k = k + 1
    
     
    
    Next objCh
    
    Next ws
    
     
    
    'Loop através de todas as folhas de gráfico.
    
    For Each objCh In ActiveWorkbook.Charts
    
    Call pptFormat(objCh, k)
    
    k = k + 2
    
    Next objCh
    
     
    
    'Mostrar o PowerPoint.
    
    pptApp.Visible = True
    
    'Limpeza de objetos
    
    Set pptSlide = Nothing
    
    Set pptPres = Nothing
    
    Set pptApp = Nothing
    
    'Informa ao Usuário que a Macro foi Concluida
    
    MsgBox "Os gráficos foram exportados com sucesso", vbOKOnly, "Produção Tecban"
    
    End Sub
    
     
    
    Private Sub pptFormat(xlCh As Chart, pptslidenumber As Integer)
    
     
    
    'Formats the charts/pictures and the chart titles/textboxes.
    
     
    
    'By Luiz Vieira Beserra Neto
    
    'Produção On_Going
    
    'Capacity Planning
    
    Dim pptApp As PowerPoint.Application
    
    Dim pptSlide As PowerPoint.Slide
    
    Dim chTitle As String
    
    Dim j As Integer
    
     
    
    On Error Resume Next
    
     
    
    'Get the chart title and copy the chart area.
    
    chTitle = xlCh.ChartTitle.Text
    
    xlCh.ChartArea.Copy
    
     
    
    'Count the slides and add a new one after the last slide.
    
    pptSlideCount = pptPres.Slides.Count
    
    Set pptSlide = pptPres.Slides.Add(pptslidenumber, ppLayoutBlank)
    
     
    
    On Error Resume Next
    
    'Paste the chart and create a new textbox.
    
    pptSlide.Shapes.PasteSpecial ppPasteJPG
    
    If chTitle <> "" Then
    
            pptSlide.Shapes.AddTextbox msoTextOrientationHorizontal, 12.5, 20, 694.75, 55.25
    
        End If
    
       
    
    'Format the picture and the textbox.
    
    For j = 1 To pptSlide.Shapes.Count
    
    With pptSlide.Shapes(j)
    
    'Picture position.
    
    If .Type = msoPicture Then
    
    .Top = 87.84976
    
    .Left = 33.98417
    
    .Height = 422.7964
    
    .Width = 646.5262
    
    End If
    
    'Text box position and formamt.
    
    If .Type = msoTextBox Then
    
                    With .TextFrame.TextRange
    
                        .ParagraphFormat.Alignment = ppAlignCenter
    
                        .Text = chTitle
    
                        .Font.Name = "Tahoma (Headings)"
    
                        .Font.Size = 28
    
                        .Font.Bold = msoTrue
    
                    End With
    
                End If
    
    End With
    
    Next j
    
    End Sub
    


    Rafael Kamimura - http://excelmaniacos.com

    sexta-feira, 16 de setembro de 2016 12:43
  • Olá Rafael, muito obrigado pela resposta.

    Está funcionando, porém, ele está criando um NOVO SLIDE, eu gostaria que os Gráficos ficassem no Slide Existente.

    Meu template tem 60 SLIDES

    eu preciso que cada vez que eu exporte um grafico, ele cole em um slide existente.. 1GRAFICO POR  1SLIDE (EXISTENTE) não criar um novo slide.

    é possível?

    sexta-feira, 16 de setembro de 2016 23:52