I would like to copy a range of data from excel and move it to
powerpoint (paste, paste special, excel worksheet object, whatever.) I
have a method that is working well in Powerpoint 2000, but the
formatting gets all screwed up in Powerpoint XP. I have a feeling it
is the "Paste" method that I use. Any advice? See code below.

Sub CreateNewPowerPointPresentation()
' to test this code, paste it into an Excel module
' add a reference to the PowerPoint-library
' create a new folder named C:\Foldername or edit the filnames in the
code
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim i As Integer, strString As String
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPres = pptApp.Presentations.Add(msoTrue) ' create a new
presentation
' or open an existing presentation
' Set pptPres =
pptApp.Presentations.Open("C:\Foldername\Filename. ppt")

' apply a slide template
' pptPres.ApplyTemplate "C:\Program Files\Microsoft
Office\Templates\Presentation Designs\x.pot"
pptPres.ApplyTemplate "\\orl40050\shared\ISQUALPAM\Metrics\Program
Small q Scorecard\Automate\PRESTON1.pot"

'Title Slide

With pptPres.Slides
Set pptSlide = .Add(.Count + 1, ppLayoutText) ' add a slide
End With

With pptSlide
Shapes(1).TextFrame.TextRange.Text = "X " ' add a slide title
Shapes(2).Delete ' remove the text box
With .Shapes(.Shapes.Count)
Left = 50
Top = 150
Width = 600
'.Height = 250
End With
End With

' Slide 2

ThisWorkbook.Worksheets(1).Range("A2:D3").Copy ' copy an Excel
range

With pptPres.Slides
Set pptSlide = .Add(.Count + 1, ppLayoutText) ' add a slide
End With
With pptSlide
Shapes(1).TextFrame.TextRange.Text = "X" ' add a slide title
Shapes(2).Delete ' remove the text box
Shapes.Paste
With .Shapes(.Shapes.Count)
Left = 25
Top = 150
Width = 50
Height = 120
End With

ThisWorkbook.Worksheets(1).Range("f3:f3").Copy ' copy an Excel
range
Shapes.Paste
With .Shapes(.Shapes.Count)
Left = 83
Top = 350
Width = 100
Height = 100
End With

ThisWorkbook.Worksheets(1).Range("g3:g3").Copy ' copy an Excel
range
Shapes.Paste
With .Shapes(.Shapes.Count)
Left = 405
Top = 350
Width = 100
Height = 100
End With

End With

' Slide 3

ThisWorkbook.Worksheets(1).Range("A6:D7").Copy ' copy an Excel
range

With pptPres.Slides
Set pptSlide = .Add(.Count + 1, ppLayoutText) ' add a slide
End With
With pptSlide
Shapes(1).TextFrame.TextRange.Text = "X" ' add a slide title
Shapes(2).Delete ' remove the text box
Shapes.Paste
' With .Shapes(.Shapes.Count)
' .Left = 25
' .Top = 150
' .Width = 50
' .Height = 120
' End With

ThisWorkbook.Worksheets(1).Range("f7:f7").Copy ' copy an Excel
range
Shapes.Paste
' With .Shapes(.Shapes.Count)
' .Left = 83
' .Top = 350
' .Width = 100
' .Height = 100
' End With

ThisWorkbook.Worksheets(1).Range("g7:g7").Copy ' copy an Excel
range
Shapes.Paste
' With .Shapes(.Shapes.Count)
' .Left = 405
' .Top = 350
' .Width = 100
' .Height = 100
' End With

End With

' Slide 4

ThisWorkbook.Worksheets(1).Range("A13:D14").Copy ' copy an Excel
range

With pptPres.Slides
Set pptSlide = .Add(.Count + 1, ppLayoutText) ' add a slide
End With
With pptSlide
Shapes(1).TextFrame.TextRange.Text = "X" ' add a slide title
Shapes(2).Delete ' remove the text box
Shapes.Paste
With .Shapes(.Shapes.Count)
Left = 25
Top = 150
Width = 50
Height = 120
End With

ThisWorkbook.Worksheets(1).Range("f14:f14").Copy ' copy an Excel
range
Shapes.Paste
With .Shapes(.Shapes.Count)
Left = 83
Top = 350
Width = 100
Height = 100
End With

ThisWorkbook.Worksheets(1).Range("g14:g14").Copy ' copy an Excel
range
Shapes.Paste
With .Shapes(.Shapes.Count)
Left = 405
Top = 350
Width = 100
Height = 100
End With

End With

' Slide 5

ThisWorkbook.Worksheets(1).Range("A17:D18").Copy ' copy an Excel
range

With pptPres.Slides
Set pptSlide = .Add(.Count + 1, ppLayoutText) ' add a slide
End With
With pptSlide
Shapes(1).TextFrame.TextRange.Text = "X" ' add a slide title
Shapes(2).Delete ' remove the text box
Shapes.Paste
With .Shapes(.Shapes.Count)
Left = 25
Top = 150
Width = 50
Height = 120
End With

ThisWorkbook.Worksheets(1).Range("f18:f18").Copy ' copy an Excel
range
Shapes.Paste
With .Shapes(.Shapes.Count)
Left = 83
Top = 350
Width = 100
Height = 100
End With

ThisWorkbook.Worksheets(1).Range("g18:g18").Copy ' copy an Excel
range
Shapes.Paste
With .Shapes(.Shapes.Count)
Left = 405
Top = 350
Width = 100
Height = 100
End With

End With

Application.CutCopyMode = False ' end cut/copy from Excel
Set pptSlide = Nothing

On Error Resume Next ' ignore errors
Kill "......\MyNewPresentation.ppt"
With pptPres
SaveAs ".....\MyNewPresentation.ppt"
'.Close ' close the presentation
End With
On Error GoTo 0 ' resume normal error handling
Set pptPres = Nothing

pptApp.Visible = True ' display the application
'pptApp.Quit ' or close the PowerPoint application
Set pptApp = Nothing
End Sub


---
Message posted from http://www.ExcelForum.com/