EXcel VBA: Excel-Makro zum Erstellen einer Tabelle in einem PowerPoint

Question

Meine Anforderung ist, ich habe ein Excel, das einige Daten enthält. Ich möchte einige Daten aus der Excel auszuwählen und eine Powerpoint-Datei zu öffnen und

Tabelle in Powerpoint erstellen und füllen Sie die Daten in ihm

Im Moment habe ich bei der Erhebung der Daten aus Excel öffnen eine gelungen PowerPoint-Datei über Excel VBA-Code.

Code zum Öffnen des PowerPoint aus 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) 

Jetzt wie ich die Tabelle in PowerPoint aus Excel erstellen und die Daten auffüllen.

Zeitnahe Hilfe wird sehr geschätzt.

Vielen Dank im Voraus, ist

Answer 1

Hier einige Code von 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

Diese Excel-VBA den ausgewählten Bereich aus Excel in einer Powerpoint-nativen Tabelle exportiert. Es funktioniert auch mit verbundenen Zellen.

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