EXcel VBA：在 PowerPoint 中创建表格的 Excel 宏

Question

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

在 PowerPoint 中创建表格并将数据填充到其中

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

从 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 在 PowerPoint 中创建表格并填充数据。

非常感谢及时的帮助。

提前致谢，

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

Answer 3

子 CreatePowerPointFromExcel() Dim pptApp 作为对象 调暗 pptPres 作为对象 变暗 pptSlide 作为对象 将 pptShape 变暗为对象 将 excelApp 调暗为 Excel.Application 将 excelWB 调暗为 Excel.Workbook 将 excelWS 调暗为 Excel.Worksheet 调暗最后一行只要 将 uniqueHeaders 调暗为对象 将 uniqueTitles 作为对象变暗 Dim headerCell 作为范围 昏暗标题单元格作为范围 昏暗表范围作为范围 将标题文本变暗为字符串 将标题文本变暗为字符串

' Initialize PowerPoint application
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True ' Make PowerPoint visible

' Create a new presentation
Set pptPres = pptApp.Presentations.Add

' Initialize Excel application
Set excelApp = Excel.Application
excelApp.Visible = False ' Don't show Excel

' Open the Excel workbook with your data
Set excelWB = excelApp.Workbooks.Open("Path to Your Excel File")
Set excelWS = excelWB.Sheets("Sheet1") ' Change sheet name if needed

' Get the last row of data in Excel
lastRow = excelWS.Cells(excelWS.Rows.Count, "A").End(xlUp).Row

' Get unique values in column B (for title slides)
Set uniqueTitles = CreateObject("Scripting.Dictionary")
For Each titleCell In excelWS.Range("B2:B" & lastRow)
    If Not uniqueTitles.Exists(titleCell.Value) Then
        uniqueTitles.Add titleCell.Value, Nothing
    End If
Next titleCell

' Loop through unique title values to create slides
For Each titleText In uniqueTitles.Keys
    ' Create a new slide with the title from column B
    Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutText)
    pptSlide.Shapes(1).TextFrame.TextRange.Text = titleText ' Set slide title
    Set pptShape = pptSlide.Shapes(2).TextFrame.TextRange ' Get text box for content
    
    ' Get unique values in column C (for table headers)
    Set uniqueHeaders = CreateObject("Scripting.Dictionary")
    For Each headerCell In excelWS.Range("C2:C" & lastRow)
        If headerCell.Offset(0, -1).Value = titleText Then ' Match title with row
            If Not uniqueHeaders.Exists(headerCell.Value) Then
                uniqueHeaders.Add headerCell.Value, Nothing
            End If
        End If
    Next headerCell
    
    ' Create a table with unique header values
    Set tableRange = pptShape.Cells(1, 1).Table
    tableRange.Columns.Delete ' Remove default columns
    tableRange.Rows.Delete ' Remove default rows
    For Each headerText In uniqueHeaders.Keys
        tableRange.Rows.Add
        tableRange.Cell(tableRange.Rows.Count, 1).Shape.TextFrame.TextRange.Text = headerText
    Next headerText
Next titleText

' Clean up
excelWB.Close SaveChanges:=False
Set excelWS = Nothing
Set excelWB = Nothing
excelApp.Quit
Set excelApp = Nothing
Set pptShape = Nothing
Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing

MsgBox "PowerPoint presentation created successfully!"

结束子