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.
