EXcel VBA：Excel宏在PowerPoint中創建表格

Question

我的要求是我有一個包含一些數據的Excel。我想選擇從Excel中的一些數據，並打開一個PowerPoint文件和

在PowerPoint中創建表並填充數據，將其

現在，我已經成功地從Excel中打開一個收集數據PowerPoint文件通過Excel VBA代碼。

從Excel打開PowerPoint的代碼。

Set objPPT = CreateObject("Powerpoint.application") 
    objPPT.Visible = True 
    Dim file As String 
    file = "C:\Heavyhitters_new.ppt" 
    Set pptApp = CreateObject("PowerPoint.Application") 
    Set pptPres = pptApp.Presentations.Open(file) 

現在我該如何在Excel中創建表格並填充數據。

及時的幫助將非常感激。

由於提前，

Answer 1

下面是http://mahipalreddy.com/vba.htm

''# Code by Mahipal Padigela 
''# Open Microsoft Powerpoint,Choose/Insert a Table type Slide(No.4), then double click to add a... 
''# ...Table(3 Cols & 2 Rows) then rename the Table to "Table1", Save and Close the Presentation 
''# Open Microsoft Excel, add some test data to Sheet1(This example assumes that you have some data in... 
''# ... Rows 1,2 and Columns 1,2,3) 
''# Open VBA editor(Alt+F11),Insert a Module and Paste the following code in to the code window 
''# Reference 'Microsoft Powerpoint Object Library' (VBA IDE-->tools-->references) 
''# Change "strPresPath" with full path of the Powerpoint Presentation created earlier. 
''# Change "strNewPresPath" to where you want to save the new Presnetation to be created later 
''# Close VB Editor and run this Macro from Excel window(Alt+F8) 

Dim oPPTApp As PowerPoint.Application 
Dim oPPTShape As PowerPoint.Shape 
Dim oPPTFile As PowerPoint.Presentation 
Dim SlideNum As Integer 
Sub PPTableMacro() 
    Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String 
    strPresPath = "H:\PowerPoint\Presentation1.ppt" 
    strNewPresPath = "H:\PowerPoint\new1.ppt" 

    Set oPPTApp = CreateObject("PowerPoint.Application") 
    oPPTApp.Visible = msoTrue 
    Set oPPTFile = oPPTApp.Presentations.Open(strPresPath) 
    SlideNum = 1 
    oPPTFile.Slides(SlideNum).Select 
    Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("Table1") 

    Sheets("Sheet1").Activate 
    oPPTShape.Table.Cell(1, 1).Shape.TextFrame.TextRange.Text = Cells(1, 1).Text 
    oPPTShape.Table.Cell(1, 2).Shape.TextFrame.TextRange.Text = Cells(1, 2).Text 
    oPPTShape.Table.Cell(1, 3).Shape.TextFrame.TextRange.Text = Cells(1, 3).Text 
    oPPTShape.Table.Cell(2, 1).Shape.TextFrame.TextRange.Text = Cells(2, 1).Text 
    oPPTShape.Table.Cell(2, 2).Shape.TextFrame.TextRange.Text = Cells(2, 2).Text 
    oPPTShape.Table.Cell(2, 3).Shape.TextFrame.TextRange.Text = Cells(2, 3).Text 

    oPPTFile.SaveAs strNewPresPath 
    oPPTFile.Close 
    oPPTApp.Quit 

    Set oPPTShape = Nothing 
    Set oPPTFile = Nothing 
    Set oPPTApp = Nothing 

    MsgBox "Presentation Created", vbOKOnly + vbInformation 
End Sub 

Answer 2

一些代碼，這Excel的VBA出口的選擇範圍從Excel到PowerPoint本地表。它也適用於合併的單元格。

Sub Export_Range() 

    Dim pp As New PowerPoint.Application 
    Dim ppt As PowerPoint.Presentation 
    Dim sld As PowerPoint.Slide 
    Dim shpTable As PowerPoint.Shape 
    Dim i As Long, j As Long 

    Dim rng As Excel.Range 
    Dim sht As Excel.Worksheet 

    Set rng = Selection 

    pp.Visible = True 
    If pp.Presentations.Count = 0 Then 
     Set ppt = pp.Presentations.Add 
    Else 
     Set ppt = pp.ActivePresentation 
    End If 

    Set sld = ppt.Slides.Add(1, ppLayoutTitleOnly) 
    Set shpTable = sld.Shapes.AddTable(rng.Rows.Count, rng.Columns.Count) 
    For i = 1 To rng.Rows.Count 
     For j = 1 To rng.Columns.Count 
      shpTable.Table.Cell(i, j).Shape.TextFrame.TextRange.Text = _ 
       rng.Cells(i, j).Text 
     Next 
    Next 

    For i = 1 To rng.Rows.Count 
     For j = 1 To rng.Columns.Count 
      If (rng.Cells(i, j).MergeArea.Cells.Count > 1) And _ 
       (rng.Cells(i, j).Text <> "") Then 
       shpTable.Table.Cell(i, j).Merge _ 
       shpTable.Table.Cell(i + rng.Cells(i, j).MergeArea.Rows.Count - 1, _ 
       j + rng.Cells(i, j).MergeArea.Columns.Count - 1) 
      End If 
     Next 
    Next 

    sld.Shapes.Title.TextFrame.TextRange.Text = _ 
     rng.Worksheet.Name & " - " & rng.Address 

End Sub