Copy/Paste Excel Range into Powerpoint using VBA (Office 2007)

[dkaspers]

I'm trying to replicate the effect of manually copying a range in Excel and pasting it into Powerpoint in Office 2007. From what I can gather, it's creating a shape with the type of msoTable. I can't seem to replicate this behavior through VBA. I think I've got all the hard stuff done, but can't figure out the easy part.

I've looked though the forums and found a bunch of solutions that don't do exactly what I need. I don't want to copypicture the range as an image - I don't want to link the data though OLE objects - I'd prefer not to dynamically recreate the table by looping through all the cells in the range and getting the values (Since I don't want to have to worry about formatting).

Sub CreatePowerPoint()
' Create an instance of PowerPoint.
Dim oPPTApp As PowerPoint.Application
Set oPPTApp = New PowerPoint.Application

' Open the Excel workbook containing the worksheet with the chart data.
Dim oWorkbook As Workbook
Set oWorkbook = ActiveWorkbook

oPPTApp.Visible = msoTrue
oPPTApp.WindowState = ppWindowMinimized

' Create a PowerPoint presentation.
Set pptPresentation = oPPTApp.Presentations.Open("C:\BenchmarkingTemplate.ppt")

Dim pptSlide As Slide
Set pptSlide = _
pptPresentation.Slides.Add(pptPresentation.Slides.Count + 1, ppLayoutTitleOnly)

Sheets("Cht1").Activate
Range(Cells(36, 1), Cells(38, 7)).Select
Selection.Copy

'This is where it crashes
Set ShapeRange = pptSlide.Shapes.Paste
ShapeRange.Left = 318
ShapeRange.Top = 96
ShapeRange.Height = 240
ShapeRange.Width = 390

' Save the presentation.
sFileName = Application.GetSaveAsFilename
pptPresentation.SaveAs (sFileName)
' Release the PowerPoint slide object.
Set ShapeRange = Nothing
Set pptSlide = Nothing
' Close and release the Presentation object.
If Not pptPresentation Is Nothing Then
pptPresentation.Close
Set pptPresentation = Nothing
End If

oPPTApp.Presentations.Open (sFileName)
oPPTApp.WindowState = ppWindowMaximized

End Sub

It crashes with: "Shapes (unkown member): Invalid request. Clipboard is empty or contains data which may not be pasted here."

Any help on how to mimic the effect of copying/pasting manually would be greatly appreciated!

 

[anusha2525]

Dim ObjPPAPP As New PowerPoint.Application
Dim objPPPres As PowerPoint.Presentation
Dim objPPSlide As PowerPoint.Slide
Public Const USER_ENTRY_SHT As String = "UserEntry"

Public Sub Proc_xl_to_ppt()
Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = False
frm_Prog.Show model = True

Set objPPPres = ObjPPAPP.ActivePresentation

Dim totSlides As Long
Dim incrSlides As Long

Application.Calculation = xlCalculationManual

If LCase(Trim(ThisWorkbook.Worksheets(USER_ENTRY_SHT).Range("j5"))) = "yes" Then
totSlides = ThisWorkbook.Worksheets(USER_ENTRY_SHT).Range("j2")
frm_Prog.progBar.Min = 0
frm_Prog.progBar.Max = totSlides
frm_Prog.progBar.Value = 0
For incrSlides = 1 To totSlides
Set objPPSlide = objPPPres.slides.Add(incrSlides, ppLayoutBlank)
Set objPPSlide = Nothing
frm_Prog.progBar.Value = frm_Prog.progBar.Value + 1
'frm_Prog.labProg.Caption = "Now at:- " & Chr(13) & "Adding Slide: " & incrSlides & " of total Slides: " & totSlides
Next incrSlides
End If



With ThisWorkbook.Worksheets(USER_ENTRY_SHT)
.Activate
Dim totRows As Long
Dim incrRows As Long

totRows = Application.WorksheetFunction.CountA(.Columns("a:a"))

Dim wb As String
Dim wst As String
Dim rng As String
Dim cht As String
Dim slideNum As Long
Dim leftNum As Long
Dim topNum As Long
Dim widthNum As Long
Dim heightNum As Long
Dim wbTemp As String
Dim totHideRows As Long
Dim totHideCols As Long


frm_Prog.progBar.Min = 0
frm_Prog.progBar.Max = totRows
frm_Prog.progBar.Value = 0
For incrRows = 2 To totRows
.Activate
wb = .Range("a" & incrRows)
wst = .Range("b" & incrRows)
rng = .Range("c" & incrRows)
cht = LCase(.Range("d" & incrRows))
slideNum = .Range("e" & incrRows)
leftNum = .Range("f" & incrRows)
topNum = .Range("g" & incrRows)
widthNum = .Range("h" & incrRows)
heightNum = .Range("i" & incrRows)

Dim newWb As String

Workbooks(wb).Activate
Worksheets(wst).Activate
If cht = "no" Then
Range(rng).CopyPicture Format:=xlPicture, Appearance:=xlScreen
Else
If cht = "yes" Then
Dim chartCount As Integer
chartCount = ActiveSheet.ChartObjects.Count
If chartCount >= 1 Then
ActiveSheet.ChartObjects(1).CopyPicture Format:=xlPicture
End If
End If
End If
Set objPPSlide = objPPPres.slides(slideNum)
objPPSlide.Shapes.Paste
'objPPSlide.Shapes.AddOLEObject Left:=leftNum, Top:=topNum, Width:=widthNum, Height:=heightNum, classname:="Paint.Picture", link:=msoFalse


Dim shp As PowerPoint.Shape
Set shp = objPPSlide.Shapes(objPPSlide.Shapes.Count)
shp.Name = wst & rng & slideNum
'objPPSlide.Shapes.Paste (objPPSlide.Shapes.Count)
shp.Left = leftNum
shp.Top = topNum
If heightNum <> 0 Then shp.Height = heightNum
If widthNum <> 0 Then shp.Width = widthNum

Set objPPSlide = Nothing

frm_Prog.progBar.Value = frm_Prog.progBar.Value + 1
Next incrRows
End With

ObjPPAPP.Activate

Set ObjPPAPP = Nothing
Set objPPPres = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

frm_Prog.Hide
MsgBox "Done", vbOKOnly, "Copy Excel Data to PPT"

End Sub
Function func_AddWbk() As String
Dim newWbAddedName As String
Workbooks.Add
ActiveWindow.DisplayGridlines = False
func_AddWbk = ActiveWorkbook.Name
End Function

 

[arpankarmakar]

Re: Copy/Paste Excel Image into Powerpoint using VBA (Office 2007)

I want to move some images from Excel to PowerPoint using VBA. I have got the following code which Opens the powerpoint file goes to the sheet mentioned in the code, but not able to paste the image in PowerPoint. Can someone please help me with this? Thanks.

This code is wokring fine in terms of copying the image, opening the powerpoint file, selecting the sheet mentioned, but not able to paste the image in powerpoint.
------------------------------------------------------------------------------------------------------------------------
Sub CopyTable()
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Call CreateObjectExample
End Sub
Sub CreateObjectExample()
Dim objApp As Object

Const ERR_APP_NOTFOUND As Long = 429
On Error Resume Next

' Attempt to create late-bound instance of Access application.
Set objApp = CreateObject("PowerPoint.Application")
If Err = ERR_APP_NOTFOUND Then
MsgBox "Power Point isn't installed on this computer. Could not automate PowerPoint."
Exit Sub
End If

With objApp
.Activate
.Presentations.Open Filename:="C:\Users\karmakaa\Desktop\Reports\OGM\Template.pptx", ReadOnly:=msoFalse
.ActivePresentation.Slides(2).Select
.Activate
.ActivePresentation.SaveAs Filename:="C:\Users\karmakaa\Desktop\Reports\OGM\Template2.pptx"
.Quit
End With

Set objApp = Nothing
End Sub