VBA: cell-data vanuit Excel naar Powerpoint

[mcgeneral]

Hoi allemaal,

Ik ben nieuw met VBA macro's en probeer een code te schrijven die vanuit 1 Excel sheet en 1 kolom data kopieert naar individuele powerpoint slides (Bv: cel A3 naar slide 3, A4 naar slide 4, etc.).
Dit omdat er 150+ bestaande slides zijn (dus geen nieuwe slides toevoegen) welke ook andere info bevatten, waarvan elke slide 1 textbox bevat die om de zoveel tijd geupdate moet worden (info staat dan in Excel) waarbij 'n macro mij handig leek.
2 manieren uiteindelijk mogelijk: info wordt puur geplakt in corresponderende slide of textbox met oude cell-data wordt vervangen door nieuwe cell-data.

Ik ben begonnen met 'n code maar geeft me nog foutmeldingen (veelal "object not active"). Kan iemand mij helpen 'm te optimaliseren? Alvast dank!

De volgende code ben ik mee bezig:

Sub test()
    Dim oPPApp As Object, oPPPrsn As Object, oPPSlide As Object
    Dim oPPShape As Object
    Dim FlName As String
    Dim i As Integer

    '~~> Change this to the relevant file
    FlName = "G:\Test.pptm"

    '~~> Establish an PowerPoint application object
    On Error Resume Next
    Set oPPApp = GetObject(, "PowerPoint.Application")

    If Err.Number <> 0 Then
        Set oPPApp = CreateObject("PowerPoint.Application")
    End If
    Err.Clear
    On Error GoTo 0

    oPPApp.Visible = True

    '~~> Open the relevant powerpoint file
    Set oPPPrsn = oPPApp.Presentations.Open(FlName)

    For i = 3 To ThisWorkbook.Sheets("RMs").Range("A65000").End(xlUp).Row
    '~~> Change this to the relevant slide which has the shape
    Next
        Set oPPSlide = oPPPrsn.slides(i)

    '~~> Write to the shape

    ThisWorkbook.Sheets("RMs").Range("A" & i).CopyPicture Appearance:=xlScreen, _
    Format:=xlPicture

    oPPSlide.Shapes.Paste.Select
     
    '
    '~~> Rest of the code
    '
End Sub

 

[snb]

Hoi Martin:

Sub M_snb()
    sn = Sheets(1).Cells(1).CurrentRegion
    
    With createObject("Powerpoint.application")
        With .presentations.Add
            For j = 1 To UBound(sn)
                With .Slides.Add(1, 12).Shapes.AddTextbox(1, 120, 120, 270, 100).TextFrame.TextRange
                  .Text = sn(j, 1)
                  .Font.Size = 40
                End With
            Next
        End With
    End With
End Sub

Tekst vervangen in een bestaande presentatie kan zo:

Sub M_snb()
    sn = Sheets(1).Cells(1).CurrentRegion
    
    With GetObject("G:\OF\voorbeeld.pptx")
       For j = 1 To UBound(sn)
          .Slides(j).Shapes("TextBox 1").TextFrame.TextRange.Text = sn(j,1)
       Next
       .application.visible=-1
    End With
End Sub

NB. dan moet wel in iedere slide het tekstvak de naam "textbox 1" hebben.
In jouw geval lijkt het me handig de tekstvakken waar het om gaat de naam "prijs" te geven en de macro daarop aan te passen.

 

[mcgeneral]

Nieuwe code

Hoi Snb,

Bedankt voor je antwoord. Ik kwam er met mijn code en die van jou echt niet uit. Ik heb 't op 'n andere boeg gegooid. Ik heb nu 'n code die mij logischer lijkt maar ook daar loop ik vast.

Code is

Sub datmacro()

Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long
Dim FlName As String

FlName = "G:\Test.pptm"

On Error Resume Next
Set myPresentation = GetObject(, "PowerPoint.Application")

If Err.Number <> 0 Then
    Set myPresentation = CreateObject("PowerPoint.Application")
End If
Err.Clear
On Error GoTo 0

myPresentation.Visible = True

Set PowerPointApp = myPresentation.Presentations.Open(FlName)
'PPT has now opened the proper file

'List of PPT Slides to Paste to
  MySlideArray = Array(2, 3, 4, 5, 6)

'Range to Copy from
  MyRangeArray = Array(9, 8, 7, 6, 5)
    
'Loop through Array data
  For x = LBound(MySlideArray) To UBound(MySlideArray)
    'Copy Excel Range
      MyRangeArray(x).Copy
    
    'Paste to PowerPoint and position
      On Error Resume Next
     '   Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
        Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
      On Error GoTo 0
    
    'Center Object
      With myPresentation.PageSetup
        shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
        shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
      End With
      
  Next x

'Transfer Complete
  Application.CutCopyMode = False
  ThisWorkbook.Activate
  MsgBox "Complete!"

End Sub

Code gezien op 'spreadsheetguru' and deze loopt vast op "MyRangeArray(x).Copy", namelijk met de error 424 - "object required".
Heel erg bedankt alvast!

 

[snb]

De enige code die je nodig hebt is de code die ik plaatste. Vergeet/verwijder iedere andere.
Simpeler code kun je niet bedenken voor deze taak.

Plaats een voorbeeld van je Excelbestand en plaats een voorbeeld van je powerpointbestand.

Zoek geen code maak schrijf code; dan begrijp je tenminste wat er gebeurt.

 

[mcgeneral]

Error 13 - mismatch

Hoi Snb,

Ok ik focus op jouw code.
De error die ik daarbij krijg is "run-time error 462 - The remote server machine does not exist or is unavailable" bij regel ".Slides(j).Shapes("Price").TextFrame.TextRange.Text = Sn(j, 1)".
Ik heb de Excel file bijgevoegd (staat nauwelijks iets in) maar de Powerpoint file is helaas geen geldig upload type. Hierin stond alleen op slide 1,2 en 3 een textvak met 'price'.

Ik hoor graag van je!

 

[snb]

zet die powerpoint even in een zip.

 

[mcgeneral]

PPT file

Alsje

 

[snb]

Draai voor de lol eens deze macro in de Powerpoint presentatie:

Sub M_snb()
    For j = 1 To ActivePresentation.Slides.Count
       MsgBox ActivePresentation.Slides(j).Shapes(1).Name
    Next
End Sub

 

[mcgeneral]

Heb 'm gedraaid, krijg 3x de melding "Content Placeholder 2" als melding in Powerpoint.

 

[snb]

Lijkt me een redelijke verklaring voor de foutmelding bij:

.Slides(j).Shapes("Price").TextFrame.TextRange.Text = sn(j, 1)

 

[mcgeneral]

Oke ik kom er dus echt pas NU achter dat ie verwijst naar de naam vd Shape, en niet zo zeer de tekst die in de shape staat.
Voor anderen die evt. willen weten wat ik heb gedaan, hier de code:

Sub doesthiswork()
        
    Sn = Sheets(1).Cells(1).CurrentRegion
    
    With GetObject("G:\LAB\METALW\RM Overview\Test.pptm")
       For j = 1 To UBound(Sn, 1)
          .Slides(j).Shapes("Content Placeholder 2").TextFrame.TextRange.Text = Sn(j, 1)
       Next
       .Application.Visible = -1
    End With
End Sub

De 'naam' van de Shape kan in Powerpoint gevonden worden bij Home > Select > Selection Pane, waar de naam "Content Placeholder 2" staat. Eenmaal dat aangepast werkte die direct.

Heel erg bedankt Snb!

 

[snb]

Nu ben je een stuk wijzer dan wanneer ik het had voorgekauwd.