✔ Programação GLOBAL®: 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.