PowerPoint 2010 Table对象组员貌似没有选取命令，所以不能直接选定粘贴数据，因此只能用比较老套的循环完成。

注：在PowerPoint2003中，可以定义一个CellArray来获取PPT Table对象中Cells的name，然后进行选区内操作。

——————————————————————————

循环效率肯定不如直接赋值的高，不过凑合能用。过程中定义了一个临时数组来存储Excel表格的数据。

Option Explicit
Sub cpExTable2PPT()
' 复制Excel表格中的数据到PPT表格的指定区域
'
'                                mxio
'                           2013.5.23
'                     @Shanghai University
'-------------------------------------------

Dim ppApp As PowerPoint.Application
Dim ppPres As Presentation
Dim xlWb As Workbook
Dim ppShape As PowerPoint.Shape
Dim ppTable As PowerPoint.Table

Dim i As Integer
Dim j As Integer

' Excel range, Columns and Rows Count
Dim rng As String
Dim rc As Integer
Dim lc As Integer
rng = "B2:E5"
rc = Range(rng).Rows.Count
lc = Range(rng).Columns.Count

' PPT table start point
Dim lstart As Integer
Dim rstart As Integer
lstart = 1
rstart = 0

' FileInfo
Dim xlPath As String
Dim xlSht As String
Dim ppPath As String

xlPath = "D:\test.xlsx"
ppPath = "D:\test.pptx"
xlSht = "Sheet1"

' PPT Slide number
Dim SlideNum As Integer
SlideNum = 1

Set xlWb = Workbooks.Open(xlPath)
xlWb.Worksheets(xlSht).Activate

On Error Resume Next
Set ppApp = GetObject(, "powerpoint.application")
If ppApp Is Nothing Then
    Set ppApp = CreateObject("powerpoint.application")
    'for automation to work, powerpoint must be visible
    ppApp.Visible = False
End If

Set ppPres = ppApp.Presentations.Open(ppPath, , , msoFalse)

For i = 1 To ppPres.Slides(SlideNum).Shapes.Count
    If ppPres.Slides(SlideNum).Shapes(i).HasTable Then
        Set ppShape = ppPres.Slides(SlideNum).Shapes(i)
        Exit For
    End If
Next

Dim CellArray()
ReDim CellArray(1 To rc, 1 To lc)

For i = 1 To rc
    For j = 1 To lc
        CellArray(i, j) = Range(rng).Cells(i, j).Text
    Next
Next

Set ppTable = ppShape.Table
With ppTable
For i = 1 To rc
    For j = 1 To lc
        .Cell(i + rstart, j + lstart).Shape.TextFrame.TextRange.Text = CellArray(i, j)
    Next
Next
End With

' Clean up and quit
ppPres.Save
ppPres.Close
ppApp.Quit

xlWb.Close savechanges:=False
Set ppTable = Nothing
Set ppShape = Nothing
Set ppPres = Nothing
Set ppApp = Nothing
               

End Sub

mxio

2013.5.23