EXcel VBA: Excel Macro để tạo bảng trong PowerPoint

Question

Yêu cầu của tôi là tôi có một Excel chứa một số dữ liệu. Tôi muốn chọn một số dữ liệu từ excel và mở một tập tin PowerPoint và

Create Table trong PowerPoint và cư dữ liệu trong nó

Ngay bây giờ tôi đã thành công trong việc thu thập dữ liệu từ excel mở Tệp PowerPoint thông qua Mã VBA Excel.

Mã để mở PowerPoint từ Excel.

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) 

Bây giờ, làm cách nào để tạo bảng trong PowerPoint từ Excel và điền dữ liệu.

Trợ giúp kịp thời sẽ được đánh giá rất nhiều.

Cảm ơn trước,

Answer 1

Dưới đây là một số mã từ 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

này Excel VBA xuất khẩu phạm vi lựa chọn từ Excel vào một bảng có nguồn gốc PowerPoint. Nó cũng hoạt động với các ô đã phối.

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