VBA code for data in PowerPoint table, not objects

[hobbes_]

Hi guys,

I have this VBA code which I use for transferring data from my data sheet to slides in PowerPoint - it works fine.

However in PowerPoint I'm currently forced to transfer data to "text-objects" which is a bit of a drag because I'm used to working in a table in Powerpoint when organizing data.

Therefore my question is how to edit my VBA code so I can transfer data to a table in PowerPoint instead of an object.

Thanks.

---

Here's the VBA code:

Sub TDPTest()
    Dim shtStudent As Worksheet
    Dim strMedarbejder As String
    Dim strTitel As String
    Dim strFastholdelse As String
    Dim lngRow As Long
    Dim objPPT As Object
    Dim objPres As Object
    Dim objSld As Object
    Dim objShp As Object
    
    Set shtStudent = Worksheets("Ark1")
        
    Set objPPT = CreateObject("Powerpoint.Application")
    objPPT.Visible = True
    Set objPres = objPPT.presentations.Open(ThisWorkbook.Path & "\JBX_test.ppt")
    objPres.SaveAs ThisWorkbook.Path & "\TDPTest.ppt"
    
    lngRow = 2
    Do While shtStudent.Cells(lngRow, 2) <> ""
        
        strMedarbejder = shtStudent.Cells(lngRow, 1)
        strTitel = shtStudent.Cells(lngRow, 2)
        strFastholdelse = shtStudent.Cells(lngRow, 3)
                       
        Set objSld = objPres.slides(1).Duplicate
        For Each objShp In objSld.Shapes
            If objShp.HasTextFrame Then
                If objShp.TextFrame.HasText Then
                    objShp.TextFrame.TextRange.Replace "<Medarbejder>", strMedarbejder
                    objShp.TextFrame.TextRange.Replace "<Titel>", strTitel
                    objShp.TextFrame.TextRange.Replace "<Fastholdelse>", strFastholdelse
                End If
            End If
        Next
        lngRow = lngRow + 1
    Loop
    objPres.slides(1).Delete
    objPres.Save
    objPres.Close
    
End Sub

 

[Worf]

Hi

See if this example is useful. It needs some tweaking but the method is there...

Sub Excel_to_PP()
    Dim shtStudent As Worksheet, objPPT As Object, objPres As Object, nrows%, i%, j%, _
    mytable As PowerPoint.Shape, tabindex%
        
    Set shtStudent = Worksheets("Ark1")
    Set objPPT = CreateObject("Powerpoint.Application")
    objPPT.Visible = True
    Set objPres = objPPT.presentations.Open(ThisWorkbook.Path & "\JBX_test.pptm")
    objPres.SaveAs ThisWorkbook.Path & "\TDPTest.pptm"
    nrows = LastRow("Ark1") - 1                         ' will copy all data on sheet
    
    Set mytable = objPres.slides(1).Shapes.AddTable(nrows, 3)
    With objPres.slides(1).Shapes
        For i = 1 To .Count
            If .Item(i).HasTable Then
                tabindex = i                            ' find the table:
                Exit For                                ' I assume you have no other tables there...
            End If
        Next
    End With
        For i = 1 To nrows
            For j = 1 To 3
                objPres.slides(1).Shapes(tabindex).Table.Cell(i, j).Shape.TextFrame.TextRange.Text = _
                shtStudent.Cells(i + 1, j).Value
            Next
        Next
        objPres.Save
        objPres.Close
End Sub


Public Function LastRow(ByVal which$) As Long
    Sheets(which).Activate
    If WorksheetFunction.CountA(Cells) = 0 Then
        LastRow = 0
        Exit Function
    End If
    LastRow = Cells.Find(What:="*", After:=[a1], SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious).Row
End Function

 

[hobbes_]

Hi

See if this example is useful. It needs some tweaking but the method is there...

Hi Worf,

Thanks for your reply.

I've tried to tweak the code for an hour now, but can't seem to find a solution that works. Here is the two files I'm working in - perhaps you can crack it.

https://rapidshare.com/files/<WBR>4009846162/Desktop.rar</SPAN></SPAN>

/H

 

[Worf]

Hi Hobbes</SPAN></SPAN>

I downloaded the example files and will post a solution soon.</SPAN></SPAN>
My idea is to previously prepare a table in PowerPoint and populate copies of it with your data.</SPAN></SPAN>

 

[Worf]

Hi Hobbes

I prepared a template table that you can see here:

https://www.dropbox.com/s/unxwy8puhqigjd2/JBX_test.ppt

Then this macro will do the job, please test it and report any problems...

Option Explicit


Sub Hobbes()
    Dim shtStudent As Worksheet, objPPT As Object, objPres As Object, nrows%, i%, j%, LastRow%
    
    Set shtStudent = Worksheets("Ark1")
    Set objPPT = CreateObject("Powerpoint.Application")
    objPPT.Visible = True
    Set objPres = objPPT.presentations.Open(ThisWorkbook.Path & "\JBX_test.ppt")
    objPres.SaveAs ThisWorkbook.Path & "\TDPFinal.ppt"
    LastRow = shtStudent.Range("b" & Rows.Count).End(xlUp).Row
    
    For i = 1 To LastRow - 2            ' first line of source data is a header
        objPres.Slides(1).Duplicate     ' create the necessary number of slides
    Next
        
    For i = 1 To LastRow - 1            ' each source data row
        For j = 1 To 3                  ' each source data column
            objPres.Slides(i).Shapes(1).Table.Cell(j + 1, 3).Shape.TextFrame.TextRange.Text = _
            shtStudent.Cells(i + 1, j).Value
        Next
    Next
    
    objPres.Save
    objPres.Close
    Set objPres = Nothing               ' clean up
    Set objPPT = Nothing
End Sub

 

[hobbes_]

Hi Worf,

It works perfectly!! - thank you so much.

I'm going to end up with apx 20 columns of data. How do I add more columns to the macro and place the data in the right cells in the PowerPoint?

/H

 

[Worf]

Hi Hobbes

I suggest you prepare a template table in PowerPoint, then run the following macro which will tell you the indexes of each cell. Knowing that you can modify my code to write on the desired cells.
If you feel it’s complicated, tell me and I’ll do it.

Sub TableCells()
Dim i%, j%, tbl As Table


' This is a PowerPoint macro, it fills a table´s cells with (#row, #column)
' assumes slide 2 has only one shape, the table, which can have merged cells


Set tbl = ActivePresentation.Slides(2).Shapes(1).Table


For i = 1 To tbl.Rows.Count
    For j = 1 To tbl.Columns.Count
        tbl.Cell(i, j).Shape.TextFrame.TextRange.Text = CStr(i) & ", " & CStr(j)
    Next
Next


End Sub

 

[hobbes_]

I understand the principle, but executing is definitely above my competence level. Would be great if you could help.

 

[Worf]

No problem, I can write it, but you must define for me the exact layout of the PowerPoint table and from what Excel cells the data is supposed to be imported.

 

[hobbes_]

Here is the two files - please let me know if you need anything else.

https://rapidshare.com/files/662991334/Desktop.rar