Paste Excel Range into Powerpoint

[scottscott]

I would like to replicate the effect of manually copying a range in Excel and pasting it into Powerpoint in Office 2007 as a Table that I could edit. I can't seem to replicate this behavior through VBA.

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.

The code that I thought would work is below but it just pastes an image rather than a editable table.

Range("K30:AD40").Copy
Set pptSlide = pptPres.Slides.Add(index:=pptPres.Slides.count + 1, Layout:=ppLayoutText)
pptSlide.Shapes.PasteSpecial ppPasteHTML, Link:=msoFalse

 

[Gavona]

this bit looks odd to me: Link:=msoFalse try msoTrue instead. Untested.

Gavin

 

[SkipVought]

hi,

please post all you code, including where you define the power point objects.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[scottscott]

The Range I am trying to paste is at the very bottom

Sub convert2pre(Optional x As Boolean)
'Eli Scott
'1/20/2012
'This Macro generates a powerpoint file for the experiment results

'Dim XLApp As Excel.Application
Dim wSheet As String
Dim ws As String
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim pptfile As String
Dim ppt As String
Dim exper As String 'experiment
Dim y As String 'year
Dim ltfile As String
Dim c As Integer
Dim j As Integer
'Dim otxtbx As TextBox

'Set XLApp = GetObject(, "Excel.Application")
wbook = ActiveWorkbook.Name
wSheet = "EXP Summary"
ppt = "Plex.pptx"


'Directories used for PP creation
pptfile = "S:\Misc\" & ppt
exper = Worksheets("10mAcm2").Cells(2, 1)
y = Year(Date)
runsheetfileloc = "S:\Run Sheets\" & y & "\"
ltfileloc = "S:\LT Summary\" & y & "\"
fpath = "S:\DC\" & y & "\"
Sheets(wSheet).Select

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'if no PP application is detected create one
If pptApp Is Nothing Then
Set pptApp = New PowerPoint.Application
End If

'Make the instance visible
pptApp.Visible = True

'Open the Plex ppt file
Set pptPres = pptApp.Presentations.Open(pptfile)
'Windows(ppt).Activate


'set pptslide to the current slide
Set pptSlide = pptPres.Slides _
(pptApp.ActiveWindow.Selection.SlideRange.SlideIndex)

'Transfer JVL Graph
Windows(wbook).Activate
With ActiveSheet.ChartObjects("JVL")
.Chart.ChartArea.Select
.Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
Format:=xlPicture
End With

With pptSlide
.Shapes.PasteSpecial ppPasteDefault
With .Shapes(.Shapes.count) ' sizes the graph on the slide
.Left = 2
.top = 75
.Width = 197
'.Height = 289.625
End With
End With

'Efficiency Voltage Graph
With ActiveSheet.ChartObjects("EV")
'.Chart.Legend.Select
'Selection.Delete

'.Chart.Axes(xlCategory).MajorUnit = 2
.Chart.ChartArea.Select
.Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
Format:=xlPicture
End With

With pptSlide
.Shapes.PasteSpecial ppPasteDefault
With .Shapes(.Shapes.count) ' sizes the graph on the slide
.Left = 197
.top = 75
.Width = 175
'.Height = 170
End With
End With

'Lm/W v Lum Graph
With ActiveSheet.ChartObjects("LMWATT")
'.Chart.Legend.Select
'Selection.Delete

'.Chart.Axes(xlCategory).MajorUnit = 2
.Chart.ChartArea.Select
.Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
Format:=xlPicture
End With

With pptSlide
.Shapes.PasteSpecial ppPasteDefault
With .Shapes(.Shapes.count) ' sizes the graph on the slide
.Left = 371
.top = 75
.Width = 175
'.Height = 170
End With
End With

With ActiveSheet.ChartObjects("EQEJ")
'.Chart.Legend.Select
'Selection.Delete

'.Chart.Axes(xlCategory).MajorUnit = 2
.Chart.ChartArea.Select
.Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
Format:=xlPicture
End With

With pptSlide
.Shapes.PasteSpecial ppPasteDefault
With .Shapes(.Shapes.count) ' sizes the graph on the slide
.Left = 545
.top = 75
.Width = 175
'.Height = 170
End With
End With

'EL Spectrum
With ActiveSheet.ChartObjects("EL")
'.Chart.Legend.Select
'Selection.Delete

'.Chart.Axes(xlCategory).MajorUnit = 2
.Chart.ChartArea.Select
.Chart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
Format:=xlPicture
End With

With pptSlide
.Shapes.PasteSpecial ppPasteDefault
With .Shapes(.Shapes.count) ' sizes the graph on the slide
.Left = 545
.top = 225
.Width = 175
'.Height = 200
End With
End With

'Add Architecture Table
pptSlide.Shapes.AddTable 10, 9, 10, 225, 600, 200
Set pptShape = pptSlide.Shapes(pptSlide.Shapes.count)

'Insert Architecture from Device tabs
pptShape.Table.Cell(1, 1).Shape.TextFrame.TextRange.Text = "Device ID"
pptShape.Table.Cell(1, 2).Shape.TextFrame.TextRange.Text = "Anode"
pptShape.Table.Cell(1, 3).Shape.TextFrame.TextRange.Text = "HIL(nm)"
pptShape.Table.Cell(1, 4).Shape.TextFrame.TextRange.Text = "HTL(nm)"
pptShape.Table.Cell(1, 5).Shape.TextFrame.TextRange.Text = "EML(nm)"
pptShape.Table.Cell(1, 6).Shape.TextFrame.TextRange.Text = "ETL(nm)"
pptShape.Table.Cell(1, 7).Shape.TextFrame.TextRange.Text = "EIL(nm)"
pptShape.Table.Cell(1, 8).Shape.TextFrame.TextRange.Text = "Cathode(nm)"
pptShape.Table.Cell(1, 9).Shape.TextFrame.TextRange.Text = "Comments"

'Format Headers
For col = 1 To 9
With pptShape.Table.Cell(1, col).Shape.TextFrame.TextRange
.Font.Size = 8
.ParagraphFormat.Alignment = ppAlignCenter
End With
Next col

'Go through each device tab and transfer each layer condition
For row = 2 To 10
'Determine Line Color(Note if more than 9 pixels are selected there will probably be an error
cline = Worksheets("Exp Summary").ChartObjects("EJ").Chart.SeriesCollection(row - 1).Border.Color
For col = 1 To 9
With pptShape.Table.Cell(row, col).Shape.TextFrame.TextRange
.Text = Worksheets("Device " & row - 1).Cells(2, col).Value
.Font.Size = 7
.Font.Color = cline
.ParagraphFormat.Alignment = ppAlignCenter
End With
Next col
Next row

'format font
'Format Table Size
pptShape.Table.Columns(1).Width = 43 'Device ID
pptShape.Table.Columns(2).Width = 40 'Anode
pptShape.Table.Columns(3).Width = 48 'HIL
pptShape.Table.Columns(4).Width = 48 'HTL
pptShape.Table.Columns(5).Width = 60 'EML
pptShape.Table.Columns(6).Width = 48 'ETL
pptShape.Table.Columns(7).Width = 80 'EIL
pptShape.Table.Columns(8).Delete 'Cathode
pptShape.Table.Columns(8).Width = 160 'Comments
'pptShape.Table.Columns(8).Width = 50 'Cathode
'pptShape.Table.rows(1).Height = 20

'Comments
' With pptSlide
' With .Shapes("Comments")
' .TextFrame.TextRange =
'' .Left = 10
'' .Top = 450
'' .Width = 700
'' .Height = 100
' End With
' End With

'Transfer 1000 Nit table to pp
Sheets("1000_nit").Select


Set pptSlide = pptPres.Slides.Add(index:=pptPres.Slides.count + 1, Layout:=ppLayoutText)
' strField = Range("K30:AD40").Value
Range("K30:AD40").Copy
pptSlide.Shapes.PasteSpecial ppPasteHTML, Link:=msoTrue

 

[scottscott]

Can anyone think of a way to paste an excel table into powerpoint? I already have the completed table in excel. Would be nice to avoid recreating the table by looping through each row and column.