Sleeper: Dynamic PowerPoint Creating by Excel

[Paleo]

Hi,

I am trying to create two PowerPoint slides from Excel VBA, but it is not working. I did create the slides and the titles, but I cant create the content. I am trying to put some data from excel in it. My code is this:

Sub MakePowerPoint()
    Dim AppPPT As New PowerPoint.Application
    Dim Pre As Presentation
    Dim Sld As Slide
    Set Pre = AppPPT.Presentations.Add
    AppPPT.Visible = True
    AppActivate "Microsoft Excel", False
    cont1 = Application.Goto(Reference:="tblRS")
    cont1 = Application.Goto(Reference:="tblUS")
    AppActivate "Microsoft PowerPoint", False
    Dim txtTexto1, txtTexto2
    txtTexto1 = Array("Title 1", "Title 2")
    txtTexto2 = Array(cont1, cont2)
    Dim i As Integer
    For i = 0 To UBound(txtTexto1)
        Set Sld = Pre.Slides.Add(Index:=i + 1, Layout:=ppLayoutText)
        With Sld
            .Shapes(1).TextFrame.TextRange.text = txtTexto1(i)
            .Shapes(2).TextFrame.TextRange.text = txtTexto2(i)
        End With
    Next
    With AppPPT
        .ActiveWindow.Selection.Unselect
        .ActivePresentation.SaveAs Filename:="C:\Paleo\powerpoint.ppt"
    End With
End Sub

[Jacob Hilderbrand]

Can you attach the Excel workbook you are using so we can get a better idea of what you want to do?

I cut out some of your code to make it work for me.

Option Explicit
   
   Sub MakePowerPoint()
Dim AppPPT          As New PowerPoint.Application
   Dim Pre             As Presentation
   Dim Sld             As Slide
   Dim i               As Integer
Set Pre = AppPPT.Presentations.Add
       AppPPT.Visible = True
For i = 1 To 2
           Set Sld = Pre.Slides.Add(Index:=i, Layout:=ppLayoutText)
           With Sld
               .Shapes(1).TextFrame.TextRange.Text = "This is the title"
               .Shapes(2).TextFrame.TextRange.Text = "This is the main body"
           End With
       Next
End Sub

Is tblRS a named range? Do you want the text from that range?

cont1 = Range("tblRS").Text

[Paleo]

Hi Jacob,

"tblRS" and "tblUS" are tables. Many rows and many columns. Named areas.

Creating a Word Document I use this code that works just fine and I need to make this for PowerPoint.

Sub MakeWord()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim myVersao As String
    myVersao = "1.0"
    Dim wordApp As Object
    Set wordApp = CreateObject("word.application")
    With wordApp
        .Documents.Add Template:="", NewTemplate:=False
        .Visible = False
        With .Selection
            .TypeText text:="Test Report"
            .Style = wordApp.ActiveDocument.Styles("Title 1")
            .Font.Size = 14
            .Font.Bold = wdToggle
            .Font.Color = wdColorDarkBlue
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
            .TypeParagraph
            .TypeText text:="Created at " + Format(Date, "Long Date")
            .TypeParagraph
            .TypeText text:="Complimentary Grades"
            .Style = wordApp.ActiveDocument.Styles("Title 2")
            .TypeParagraph
        End With
        With .ActiveDocument.Bookmarks
            .Add Range:=wordApp.Selection.Range, _
                Name:="Grades"
            .DefaultSorting = wdSortByName
            .ShowHidden = False
        End With
        With .Selection
            .TypeParagraph
            .TypeParagraph
            .TypeText text:="Report prepared by Excel Macro version " + myVersao
            .TypeParagraph
        End With
    End With
    AppActivate "Microsoft Excel", False
    Application.Goto Reference:="tblRS"
    Selection.Copy
    wordApp.Selection.Goto Name:="Grades"
    wordApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
        Placement:=wdFloatOvertext, DisplayAsIcon:=False
    wordApp.ActiveDocument.SaveAs Filename:="Grades " & Month(Date) _
        & Year(Date) & ".doc", FileFormat:=wdFormatDocument, LockComments:=False, _
        Password:="", AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
        EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False
    wordApp.Application.Quit
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

[Jacob Hilderbrand]

Try this:

Option Explicit
 
 Sub MakePowerPoint()
Dim AppPPT              As New PowerPoint.Application
 Dim Pre                 As Presentation
 Dim Sld                 As Slide
 Dim txtTexto1(1 To 2)   As String
 Dim txtTexto2(1 To 2)   As Range
 Dim i                   As Long
 Dim cont1               As Range
 Dim cont2               As Range
Set Pre = AppPPT.Presentations.Add
     AppPPT.Visible = True
Set cont1 = Range("tblRS")
     Set cont2 = Range("tblUS")
txtTexto1(1) = "Title 1"
     txtTexto1(2) = "Title 2"
     Set txtTexto2(1) = cont1
     Set txtTexto2(2) = cont2
For i = 1 To 2
         Set Sld = Pre.Slides.Add(Index:=i, Layout:=ppLayoutText)
         With Sld
             .Shapes(1).TextFrame.TextRange.Text = txtTexto1(i)
             txtTexto2(i).Copy
             .Shapes(2).TextFrame.TextRange.Paste
         End With
     Next
AppPPT.ActivePresentation.SaveAs Filename:="C:\Paleo\powerpoint.ppt"
End Sub

[Paleo]

Hi Jacob,

well it generated the PowerPoint and it was great, but my tables have lost their alignments. How could I tell PowerPoint it should be shown as a table?

[Paleo]

I have tried using this code:

ActiveWindow.Selection.SlideRange.Shapes.AddOLEObject _
     (Left:=120, Top:=110, Width:=480, Height:=320, _
     ClassName:="Excel.Sheet.8", Link:=msoFalse).Select
 ActiveWindow.Selection.ShapeRange.OLEFormat.Activate
 With ActiveWindow.Selection.ShapeRange
     .Left = 119.625
     .Top = 110.25
     .Width = 480.75
     .Height = 319.5
 End With

But it didnt work. Any help?

[Jacob Hilderbrand]

You can add a table like there. Then put the data in cell buy cell.

With Sld
             .Shapes(1).TextFrame.TextRange.Text = txtTexto1(i)
             txtTexto2(i).Copy
             .Shapes(2).TextFrame.TextRange.Paste
             .Shapes.AddTable 3, 2
         End With

[Paleo]

Hi Jacob,

ok, this code inserted a table with 3 rows and 2 columns, but its not what I need yet. I need to show the content from txtTexto2(i) in that table. This text is an excel sheet contaning 9 columns and 13 rows. Any suggestions?

[Jacob Hilderbrand]

You can change the table to the number of rows/columns you want.

.Shapes.AddTable 13, 9

[Paleo]

Hi Jacob,

sorry I misexpressed. Ok, I can creat the table to size I want but my problem is: I need to put the txtTexto2(i) content inside that table. How may I do that?

[Jacob Hilderbrand]

You can try something like this to add the text to each cell in the table.

Sub MakePowerPoint()
       
      Dim AppPPT              As New PowerPoint.Application
      Dim Pre                 As Presentation
      Dim Sld                 As Slide
      Dim txtTexto1(1 To 2)   As String
      Dim txtTexto2(1 To 2)   As Range
      Dim i                   As Long
      Dim cont1               As Range
      Dim cont2               As Range
      Dim Table1              As PowerPoint.Shape
      Dim j                   As Long
      Dim TextCol             As New Collection
      Dim Counter             As Long
Set Pre = AppPPT.Presentations.Add
      AppPPT.Visible = True
Set cont1 = Range("tblRS")
      'Set cont2 = Range("tblUS")
'txtTexto1(1) = "Title 1"
      'txtTexto1(2) = "Title 2"
      Set txtTexto2(1) = cont1
      Set txtTexto2(2) = cont2
For i = 1 To 13 'Rows
          For j = 1 To 9 'Columns
              TextCol.Add Cells(i, j).Text
          Next j
      Next i
      For i = 1 To 1
          Set Sld = Pre.Slides.Add(Index:=i, Layout:=ppLayoutText)
          With Sld
              '.Shapes(1).TextFrame.TextRange.Text = txtTexto1(i)
              'txtTexto2(i).Copy
              '.Shapes(2).TextFrame.TextRange.Paste
              Set Table1 = .Shapes.AddTable(13, 9)
              With Table1
                  For j = 117 To 1 Step -1
                      Counter = Counter + 1
                      On Error Resume Next
                      .GroupItems(Index:=j).TextFrame.TextRange.Text = _
 TextCol(Counter)
                  Next j
              End With
End With
      Next
'AppPPT.ActivePresentation.SaveAs Filename:="C:\Paleo\powerpoint.ppt"
End Sub