VBA Excel Intermediário - Exportando DOIS Ranges Simultaneamente para o PowerPoint

VBA Excel Intermediário - Exportando DOIS Ranges Simultaneamente para o PowerPoint

Sim, caso nosso Dashboard seja grande demais, ou tenha pequenas partes que gostaria de destacar durante a sua apresentação, talvez decida exportar pequenas partes em slides separados, logo após tê-los exportado juntos.

Ter a liberdade de poder efetuar essa exportação com a mesma funcionalidade técnica é sempre uma bem recebida solução para a nossa correria do dia a dia.

Um plus+ neste código é o que verá no arremate da colagem da imagem, quando o script tenta adequar o tamanho da imagem ao slide onde está sendo colado. 

Começa assim:

    Dim nTitle As String
    Dim nRngName01 As String

    Dim nRngName02 As String

     Let nRngName01 = "TOP"
     Let nRngName02 = "BODY"

     Let nTitle = ActiveSheet.Range("AB9").Value

    Call XPortRng2PPT (nRngName01, nRngName02, nSheetName, nTitle)

Continue assim:

Sub XPortRng2PPT (nRngName01 As String, nRngName02 As String, nSheet As String, nTitle As String)
    '      Author: André Luiz Bernardes - A&A - In Any Place - andreluizbernardes@gmail.com
    '        Date: 01/06/2016 - 10:32
    ' Application: Field Force Dashboard Analysis® 
    '     Purpose: Copy/Paste An Excel Range Into a New PowerPoint Presentation

    Dim ActFileName As Variant
    Dim ScaleFactor As Single

    On Error GoTo ErrorHandling

    Let ActFileName = Application.GetOpenFilename("Microsoft PowerPoint-Files (*.pptx), *.ppt")
    Let ScaleFactor = Range("myScaleFactor").Value

    Application.Sheets(nSheet).Select

    Set PP = CreateObject("Powerpoint.Application")

    If ActFileName = False Then
        PP.Activate
        PP.Presentations.Add
        Set PP_File = PP.ActivePresentation
    Else
        PP.Activate
        Set PP_File = PP.Presentations.Open(ActFileName)
    End If

    Let PP.Visible = True

    CopyandPastetoPPT nRngName01, nTitle, ScaleFactor, ScaleFactor
    CopyandPastetoPPT nRngName02, nTitle, ScaleFactor, ScaleFactor

    Set PP_Slide = Nothing
    Set PP_File = Nothing
    Set PP = Nothing

    Application.Sheets(nSheet).Activate
Exit Sub

ErrorHandling:

Set PP_Slide = Nothing
Set PP_File = Nothing
Set PP = Nothing

MsgBox "Error No.: " & Err.Number & vbNewLine & vbNewLine & "Description: " & Err.Description, vbCritical, "Error"

End Sub

Sub CopyandPastetoPPT (myRangeName As String, _
                              myTitle As String, _
                              myScaleHeight As Single, _
                              myScaleWidth As Single)
    '      Author: André Luiz Bernardes - A&A - In Any Place - andreluizbernardes@gmail.com
    '        Date: 01/06/2016 - 10:32
    ' Application: Field Force Dashboard Analysis®
    '     Purpose: Copy/Paste.

    Dim NextShape As Integer

    Application.GoTo Reference:=myRangeName

    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    Range("A1").Select

    PP.ActivePresentation.Slides.Add PP.ActivePresentation.Slides.Count + 1, 11

    Set PP_Slide = PP_File.Slides(PP.ActivePresentation.Slides.Count)
    Let PP_Slide.Shapes.Title.TextFrame.TextRange.Text = myTitle
    Let NextShape = PP_Slide.Shapes.Count + 1

    PP_Slide.Shapes.PasteSpecial 2
    
    PP_Slide.Shapes(NextShape).ScaleHeight myScaleHeight, 1
    PP_Slide.Shapes(NextShape).ScaleWidth myScaleWidth, 1
    PP_Slide.Shapes(NextShape).Left = PP_File.PageSetup.SlideWidth \ 2 - PP_Slide.Shapes(NextShape).Width \ 2
    PP_Slide.Shapes(NextShape).Top = 90

End Sub


Se gostou, compartilhe este post com outros! Deixe seus comentários e sugestões.

brazilsalesforceeffectiveness@gmail.com