Eu inseri um inputbox para voce selecionar os intervalos de celula que deseja inserir em cada slide:
Vejas e atende:

Sub ExcelRangeToPowerPoint_2()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'SOURCE: www.TheSpreadsheetGuru.com

Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim strFile  As Variant
Dim strRng As Range
' ALTERE LINHA ABAIXO: local do seu *.PPT
 strFile = "C:usersAdminDesktopapresentação1.pptx"  
Set strRng = Application.InputBox("Selecione o intervalo", "Definindo Intervalor", Type:=8) ' '("A1:C12")
'Copy Range from Excel
  Set rng = ThisWorkbook.ActiveSheet.Range(strRng.Address)
'Create an Instance of PowerPoint
  On Error Resume Next
    
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    
    'Clear the error between errors
      Err.Clear

    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If

  On Error GoTo 0

'Optimize Code
  Application.ScreenUpdating = False
  
'Create a New Presentation
  'Set myPresentation = PowerPointApp.Presentations.Add
 Set myPresentation = CreateObject("PowerPoint.Application")
   myPresentation.Presentations.Open strFile
   
'Add a slide to the Presentation
With myPresentation.ActivePresentation
  Set mySlide = .Slides.Add(.Slides.Count + 1, Layout:=ppLayoutCustom)
End With

'Copy Excel Range
  rng.Copy

'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  
    'Set position:
      myShape.Left = 66
      myShape.Top = 152

'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate

'Clear The Clipboard
  Application.CutCopyMode = False
  
End Sub

Basole,
Thanks, but an error occured on this line:

Set mySlide = .Slides.Add(.Slides.Count + 1, Layout:=ppLayoutCustom)

Could you pls help me to fix it?

Basole,

Desconsidere o texto acima.

Não sei porque mas ocorreu um erro na linha abaixo:

Set mySlide = .Slides.Add(.Slides.Count + 1, Layout:=ppLayoutCustom)

Saberia me informar o que pode ter ocorrido?

Obrigado pela Ajuda!

Marque a referencia Microsoft PowerPoint XX.X Object library no Excel

Vou pedir licença ao criador do tópico, mas esse assunto era exatamente o que estava procurando.

Tenho a seguinte duvida:

A macro atual sempre que é acionada ela cria uma nova apresentação, e no meu caso gostaria que a mesma sempre utiliza-se a mesma apresentação porem criando um novo slide. Ou seja, ao acionar a macro ela copia o conteudo na range escolhida e cria um novo slide e cola, e assim por diante.

Alguem pode ajudar a modificar o codigo para que fizesse isso?

JokerPot, talvez não tenha reparado, mas este é o mesmo objetivo do autor do tópico:

Copie, cole e ajuste o codigo e teste, deste link: https://goo.gl/d2i0q0

*E não esqueça de marcar a referencia Microsoft PowerPoint XX.X Object library no Excel

Bom Dia!

Consegui fazer algumas alterações no código.
Coloquei o endereço do arquivo PowerPoint em uma celula específica, bem como a RANGE de celulas a serem copiadas escrita em cada CELULA, por exemplo:

A1 = B4:Q11
A2 = B4:Q13
A3 = B4:Q17

Por ultimo consegui inserir um loop para que ele faça esse trabalho até o fim das celulas que quero que copie sempre inserindo um slide novo em branco.

Não sou programador mas ficou boa para o que necessito.

Sub ExcelRangeToPowerPoint_2()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'SOURCE: www.TheSpreadsheetGuru.com

Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim strFile  As Variant
Dim strRng As Range

' ALTERE LINHA ABAIXO: local do seu *.PPT

strFile = Sheets("EXEMPLO").Cells(2, 24).Value


ULTIMA_LINHA = Sheets("EXEMPLO").Range("B1048576").End(xlUp).Row





'Copy Range from Excel
'  Set rng = ThisWorkbook.ActiveSheet.Range(strRng.Address)
'Create an Instance of PowerPoint
  On Error Resume Next
   
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
   
    'Clear the error between errors
      Err.Clear

    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
   
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint não está disponível, saindo."
        Exit Sub
      End If

  On Error GoTo 0

'Optimize Code
  Application.ScreenUpdating = False
 
'Create a New Presentation
  'Set myPresentation = PowerPointApp.Presentations.Add
Set myPresentation = CreateObject("PowerPoint.Application")
   myPresentation.Presentations.Open strFile
   
   
n_IMP = 4
n_XPT = 1
   
For n_IMP = 4 To ULTIMA_LINHA

SAIR = Sheets("EXEMPLO").Cells(3, 1).Value

CONTEUDO = Sheets("EXEMPLO").Cells(n_XPT, 1).Value
Range(CONTEUDO).Copy
   
   
         
'Add a slide to the Presentation
With myPresentation.ActivePresentation
  Set mySlide = .Slides.Add(.Slides.Count + 1, Layout:=ppLayoutBlank)
End With

'Copy Excel Range
'  rng.Copy

'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=3  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
 
    'Set position:
      myShape.Left = 66
      myShape.Top = 55

'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate

'Clear The Clipboard
  Application.CutCopyMode = False
 
If SAIR = CONTEUDO Then
Exit For
End If

n_XPT = n_XPT + 1

Next
 
 
 
End Sub

Basole e JokerPot,

Muito Obrigado pela ajuda!

Grande Abraço