EXcel VBA: Excel Makro PowerPoint'te tablo oluşturmak için

Question

Benim gereksinim bazı verileri içeren bir Excel'im var. Ben verileri excel bazı verileri seçin ve açılır

PowerPoint'te Tablo oluşturma PowerPoint dosyası ve

ve doldurmak istiyorum Şu anda excel bir açılış veri toplamayı başardı o

için Excel VBA Kodu ile PowerPoint dosyası.

PowerPoint'i Excel'den Açma Yasası.

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) 

Şimdi tabloyu Excel'den Excel'de oluşturabilir ve verileri doldururum.

Zamanında yardım çok takdir edilecektir. peşin

sayesinde

Answer 1

İşte bu Excel VBA bir PowerPoint yerli tabloya Excel seçilen aralık ihraç 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

bazı kod. Ayrıca birleştirilmiş hücrelerle çalışır.

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