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

cabotha

New Member
Joined
May 26, 2016
Messages
4
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.
 

Some videos you may like

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.

cabotha

New Member
Joined
May 26, 2016
Messages
4
Code:
 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

New Member
Joined
May 26, 2016
Messages
4
Above I have put my code. The cell I need to copy from is O10, but I cant seem to get it to work
 

Watch MrExcel Video

Forum statistics

Threads
1,099,473
Messages
5,468,829
Members
406,612
Latest member
pedad

This Week's Hot Topics

Top