Copying one Cell of text in excel and pasting it into PPT as a textbox

[cabotha]

I have written a code that enters information into one cell, populates an excel template I've made, then creates a PPT file and slide, pastes the template in, creates a new slide and goes onto the next data point in excel to populate the template with the new information.

It is doing all of that by pasting the template from excel to PPT as an EMF, but there is one piece of info I need to move over in a text box so users can command-F search for this info on the slides.

 

[cabotha]

 Sub repplan()
 

 
 'POWERPOINT SETUP -----------------------------------------------------------------------------------------------------------------
 
Dim PowerPointApp As Object
Dim myPresentation As Object

'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
  
  'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add
  
'POWERPOINT SETUP COMPLETE -----------------------------------------------------------------------------------------------------------------
 
 
 'SELECTING THE DATA TO USE (SITE NUMBER COLUMN AND ALL CELLS USED IN THE WORKSHEET--------------------------------------------------------------
 
  Dim rng As Range
 'Set Range from Excel
Set rng = Sheet1.Range("A1:S208")

Range("S5").Select

'SELECTING CELLS COMPLETE --------------------------------------------------------------------------------------------------------------------------
      
'LOOP-----------------------------------------------------------------------------------------------------------------------------
     
      ' Set Do loop to stop when an empty cell is reached.
      Do Until IsEmpty(ActiveCell)
      
 
  

ActiveCell.Copy Sheet1.Range("P4")

Dim mySlide As Object
Dim myShape As Object




'Optimize Code
  Application.ScreenUpdating = False

'Add a slide to the Presentation
  Set mySlide = myPresentation.Slides.Add(1, 1) '1 = ppLayoutTextbox only

'Copy Excel Range
  Range("A1:M36").Copy

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

    'Set position and size:
      myShape.Left = 0
      myShape.Top = 0
    myShape.Height = 540
    myShape.Width = 720
'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate

'Clear The Clipboard
  Application.CutCopyMode = False
  
'Copy and paste the site number text box into the powerpoint
'Range("O10").Copy
'mySlide.Shapes.Paste
'Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'myShape.Left = 0
'myShape.Top = 0

    'Clear The Clipboard
  Application.CutCopyMode = False
         ' Step down 1 row from present location.
         ActiveCell.Offset(1, 0).Select
         
      Loop
'LOOP COMPLETE---------------------------------------------------------------------------------------------------------------------------------
    
'DIALOG BOX TO CONFIRM TRANSFER HAS BEEN COMPLETED WITHOUT ERRORS
MsgBox ("Completed transfer to Powerpoint")

   End Sub

 

[cabotha]

Above I have put my code. The cell I need to copy from is O10, but I cant seem to get it to work