VBA CODE que coleta informações do Excel e transporta para o PPT - melhorias no código são bem vindas.

[VBA CODE FROM EXCEL TO POW]

Olá, pessoal, bom dia, tudo bem?

Poderiam me ajudar a melhorar o código abaixo? Fiz sozinho, sem conhecimento prévio, e ele funciona as vezes....rs - as vezes da erro.

Coisas que eu queria melhorar: Dar opção ao usuário escolher a origem do arquivo, ao invés de ele ser obrigado a deixar o arquivo salvo no C:\Users\Public\filename.pptx.

 

Outra coisa, meu código é tão amador que ele copia e cola 1900x o mesmo item, mas de celulas diferentes. Quando as informações chegam no Powerpoint, elas estão sendo coladas nos campos corretos, da maneira correta. 

Alguém pode me ajudar, por favor?

 

Sub PasteExcelDataIntoPowerPointTextbox()
    Dim ppApp As Object
    Dim ppSlide As Object
    Dim ppTextBox As Object
    Dim xlApp As Excel.Application
    Dim xlWorkbook As Excel.Workbook
    Dim xlWorksheet As Excel.Worksheet
    Dim excelRange As Excel.Range
    
    ' Initialize PowerPoint and Excel
    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True ' Make PowerPoint visible
    
   
    ' Open the PowerPoint presentation
    Set ppPresentation = ppApp.Presentations.Open("C:\Users\Public\filename.pptx")
    
    
    ' Assuming the Excel file is already open, else you can open it too
    Set xlApp = GetObject(, "Excel.Application")
    Set xlWorkbook = xlApp.ActiveWorkbook
    Set xlWorksheet = xlWorkbook.Worksheets("HiringResults") ' Change to your sheet name
    
    ' Get the range of Excel data you want to copy
    Set excelRange = xlWorksheet.Range("C1")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFTYPE").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
    Set excelRange = xlWorksheet.Range("C2")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFBUSINESS").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
    Set excelRange = xlWorksheet.Range("D3")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFNUMBERFILLS").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
    
    Set excelRange = xlWorksheet.Range("D4")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFVARIATION").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
    Set excelRange = xlWorksheet.Range("D5")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFTTF").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
    
        Set excelRange = xlWorksheet.Range("D6")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFCNPS").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
        Set excelRange = xlWorksheet.Range("D7")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFHMNPS").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
        Set excelRange = xlWorksheet.Range("D8")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFACTREQ").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
        Set excelRange = xlWorksheet.Range("D9")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFDIVMALE").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
        Set excelRange = xlWorksheet.Range("D10")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFDIVFAME").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
        Set excelRange = xlWorksheet.Range("D11")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFHIREINT").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
        Set excelRange = xlWorksheet.Range("D12")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFHIREEXT").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
        Set excelRange = xlWorksheet.Range("D13")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFTSTASO").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
        Set excelRange = xlWorksheet.Range("D14")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFTSEMRE").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
        Set excelRange = xlWorksheet.Range("D15")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFTSAGENC").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
        Set excelRange = xlWorksheet.Range("D16")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFLEVEX").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
        Set excelRange = xlWorksheet.Range("D17")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFLEVDI").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
        Set excelRange = xlWorksheet.Range("D18")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFLEVMA").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
        Set excelRange = xlWorksheet.Range("D19")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFLEVIN").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
        Set excelRange = xlWorksheet.Range("D20")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFDATAREF").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
    
    
        Set excelRange = xlWorksheet.Range("D21")
    Set ppSlide = ppPresentation.Slides(1)
    Set ppTextBox = ppSlide.Shapes("REFKEYINSIGHTS").TextFrame.TextRange
    excelRange.Copy
    ppTextBox.Paste
       
    ' Clean up
    Set ppApp = Nothing
    Set xlApp = Nothing
    Set xlWorkbook = Nothing
    Set xlWorksheet = Nothing
    Set ppPresentation = Nothing
    
 MsgBox "Report completed. Please edit and save it."
 
End Sub

 

[Alyson Ronnan Martins]

Bom dia @VBA CODE FROM EXCEL TO POW

Olha se o código abaixo consegue funcionar no seu processo.

Sub PasteExcelDataIntoPowerPointTextbox()
    Dim ppApp As Object
    Dim ppSlide As Object
    Dim ppTextBox As Object
    Dim xlApp As Excel.Application
    Dim xlWorkbook As Excel.Workbook
    Dim xlWorksheet As Excel.Worksheet
    Dim excelRange As Excel.Range
    Dim filePath As String
    
    ' Initialize PowerPoint and Excel
    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True ' Make PowerPoint visible
    
    ' Get the PowerPoint file path
    filePath = Application.GetOpenFilename("PowerPoint Files (*.pptx), *.pptx")
    If filePath = "False" Then Exit Sub ' User cancelled
    
    ' Open the PowerPoint presentation
    Set ppPresentation = ppApp.Presentations.Open(filePath)
    
    ' Assuming the Excel file is already open, else you can open it too
    Set xlApp = GetObject(, "Excel.Application")
    Set xlWorkbook = xlApp.ActiveWorkbook
    Set xlWorksheet = xlWorkbook.Worksheets("HiringResults") ' Change to your sheet name
    
    ' Define the ranges and corresponding shape names
    Dim ranges As Variant
    Dim shapes As Variant
    ranges = Array("C1", "C2", "D3", "D4", "D5", "D6", "D7", "D8", "D9", "D10", "D11", "D12", "D13", "D14", "D15", "D16", "D17", "D18", "D19", "D20", "D21")
    shapes = Array("REFTYPE", "REFBUSINESS", "REFNUMBERFILLS", "REFVARIATION", "REFTTF", "REFCNPS", "REFHMNPS", "REFACTREQ", "REFDIVMALE", "REFDIVFAME", "REFHIREINT", "REFHIREEXT", "REFTSTASO", "REFTSEMRE", "REFTSAGENC", "REFLEVEX", "REFLEVDI", "REFLEVMA", "REFLEVIN", "REFDATAREF", "REFKEYINSIGHTS")
    
    ' Loop through the ranges and shapes
    For i = 0 To UBound(ranges)
        Set excelRange = xlWorksheet.Range(ranges(i))
        Set ppSlide = ppPresentation.Slides(1)
        Set ppTextBox = ppSlide.Shapes(shapes(i)).TextFrame.TextRange
        excelRange.Copy
        ppTextBox.Paste
    Next i
    
    ' Clean up
    Set ppApp = Nothing
    Set xlApp = Nothing
    Set xlWorkbook = Nothing
    Set xlWorksheet = Nothing
    Set ppPresentation = Nothing
    
    MsgBox "Report completed. Please edit and save it."
End Sub