EXcel VBA：Excelmacros在PowerPoint中创build表

我的要求是我有一个包含一些数据的Excel。 我想从Excel中select一些数据并打开PowerPoint文件

在PowerPoint中创build表格并填入数据

现在我已经成功地从excel中收集数据，通过Excel VBA代码打开一个PowerPoint文件。

从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中创buildPowerPoint中的表格并填充数据。

及时的帮助将非常感激。

提前致谢，

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